VistA-FOIAVistA/r/EVENT_CAPTURE-EC--ECT--ECX/ECMLMP.m

210 lines
7.2 KiB
Mathematica

ECMLMP ;ALB/ESD - Multiple procedure dates and procedures ;22 AUG 1997 11:11
;;2.0; EVENT CAPTURE ;**5,18,47**;8 May 96
;
EN ;- ListMan entry point
;
D EN^VALM("EC MUL PROCEDURES")
Q
;
HDR ;- Display location, provider #1, DSS Unit, and Category as header
;
S VALMHDR(1)=" Location: "_$G(ECLN)_" ("_$G(ECL)_")"
S VALMHDR(1)=$$SETSTR^VALM1("Provider #1: "_$P(ECU(1),"^",2),VALMHDR(1),40,30)
S VALMHDR(2)=" DSS Unit: "_$P(ECDSSU,"^",2)
S VALMHDR(2)=$$SETSTR^VALM1(" Category: "_$P(ECCAT,"^",2),VALMHDR(2),40,30)
;
Q
;
INIT ;- Initialize variables and call BLD which does processing
;
N BL,ECPCNT,IC,IW,DC,DW,NC,NW,PC,PW,RC,RW,VC,VW,X,MC,MW
D CLEAN^VALM10
K ^TMP("ECM",$J),^TMP("ECMP",$J),^TMP("ECMPIDX",$J)
;K XQORNOD,%B
;
S (VALMCNT,ECPCNT)=0
S BL="",$P(BL," ",30)=""
S X=VALMDDF("INDEX"),IC=$P(X,"^",2),IW=$P(X,"^",3)
S X=VALMDDF("PROC DT"),DC=$P(X,"^",2),DW=$P(X,"^",3)
S X=VALMDDF("PROC NUM"),NC=$P(X,"^",2),NW=$P(X,"^",3)
S X=VALMDDF("PROCEDURE"),PC=$P(X,"^",2),PW=$P(X,"^",3)
S X=VALMDDF("VOL"),VC=$P(X,"^",2),VW=$P(X,"^",3)
S X=VALMDDF("REASON"),RC=$P(X,"^",2),RW=$P(X,"^",3)
S X=VALMDDF("MODIFIER"),MC=$P(X,"^",2),MW=$P(X,"^",3)
;
D BLD
S $P(^TMP("ECMP",$J,0),"^",4)=VALMCNT
Q
;
BLD ;- Combine arrays and build lines with data for display
;
D COMBINE
;
N ECPD,ECNT,ECX
S ECPD=0 F S ECPD=$O(^TMP("ECM",$J,ECPD)) Q:'ECPD D
. S ECNT=0 F S ECNT=$O(^TMP("ECM",$J,ECPD,ECNT)) Q:'ECNT D BLDLM
;
Q
;
BLDLM ;- Build each line for display and create ^TMP("ECMPIDX",$J) array
;
N ECPR,ECCPT K ECX
S ECPCNT=ECPCNT+1,ECX="",$P(ECX," ",VALMWD+1)=""
S ECX=$E(ECX,1,IC-1)_$E(ECPCNT_BL,1,IW)_$E(ECX,IC+IW+1,VALMWD)
S ECX=$E(ECX,1,DC-1)_$E($$FTIME^VALM1(ECPD)_BL,1,DW)_$E(ECX,DC+DW+1,VALMWD)
S ECX=$E(ECX,1,NC-1)_$E($P($P(^TMP("ECM",$J,ECPD,ECNT),"^"),";")_BL,1,NW)_$E(ECX,NC+NW+1,VALMWD)
S ECCPT=$P(^TMP("ECM",$J,ECPD,ECNT),"^")
S ECCPT=$S(ECCPT["ICPT":+ECCPT,1:$P($G(^EC(725,+ECCPT,0)),"^",5))
I ECCPT'="" S ECCPT=$P($$CPT^ICPTCOD(ECCPT,ECPD),U,2)
S ECPR=$S(ECCPT'="":ECCPT_" ",1:ECCPT)_$P(^TMP("ECM",$J,ECPD,ECNT),"^",2)
S ECX=$E(ECX,1,PC-1)_$E($E(ECPR,1,30)_BL,1,PW)_$E(ECX,PC+PW+1,VALMWD)
S ECX=$E(ECX,1,VC-1)_$E($P(^TMP("ECM",$J,ECPD,ECNT),"^",5)_BL,1,VW)_$E(ECX,VC+VW+1,VALMWD)
;
D SET(ECX)
;
S ^TMP("ECMPIDX",$J,ECPCNT)=VALMCNT_"^"_ECPD_"^"_$P(^TMP("ECM",$J,ECPD,ECNT),"^")_"^"_$P(^TMP("ECM",$J,ECPD,ECNT),"^",2)_"^"_$P(^TMP("ECM",$J,ECPD,ECNT),"^",3)_"^"_$P(^TMP("ECM",$J,ECPD,ECNT),"^",4)_"^"_$P(^TMP("ECM",$J,ECPD,ECNT),"^",5)
;
I $D(^TMP("ECM",$J,ECPD,ECNT,"MOD")) D K MOD
. S MOD="",ECX=$E(BL,1,26)_"Modifier:"
. F S MOD=$O(^TMP("ECM",$J,ECPD,ECNT,"MOD",MOD)) Q:MOD="" D
. . S ECX=$E(ECX,1,MC-1)_" - "_MOD_" "_$E($P(^TMP("ECM",$J,ECPD,ECNT,"MOD",MOD),"^")_BL,1,MW)_$E(ECX,MC+MW+1,VALMWD)
. . D SET(ECX) K ECX S ECX=BL_" "
. M ^TMP("ECMPIDX",$J,ECPCNT,"MOD")=^TMP("ECM",$J,ECPD,ECNT,"MOD")
;
K ECX
S ECX=" "
S ECX=$E(ECX,1,RC-1)_"Procedure Reason: "_$E($P(^TMP("ECM",$J,ECPD,ECNT),"^",4)_BL,1,RW)_$E(ECX,RC+RW+1,VALMWD)
D SET(ECX)
K ECX S ECX=BL D SET(ECX)
Q
;
;
SET(X) ;- Create display array ^TMP("ECMP",$J)
;
S VALMCNT=VALMCNT+1,^TMP("ECMP",$J,VALMCNT,0)=X
S ^TMP("ECMP",$J,"IDX",VALMCNT,ECPCNT)=""
Q
;
HLPS ;- Brief help
;
S X="?" D DISP^XQORM1 W !!
Q
HELP ;- Help for list
S ECZ=""
I $D(X),X'["??" D HLPS,PAUSE^VALM1 G HLPQ
D CLEAR^VALM1
F I=1:1 S ECZ=$P($T(HELPTXT+I),";",3,99) Q:ECZ="$END" D PAUSE^VALM1:ECZ="$PAUSE" Q:'Y W !,$S(ECZ["$PAUSE":"",1:ECZ)
W !,"Possible actions are the following:"
D HLPS,PAUSE^VALM1 S VALMBCK="R"
HLPQ K ECZ,Y,I Q
;
EXIT ;- Clean up and exit
;
K ^TMP("ECPRDT",$J),^TMP("ECPROC",$J)
K ^TMP("ECM",$J),^TMP("ECMP",$J)
K VALMDDF
D CLEAN^VALM10,CLEAR^VALM1
Q
;
COMBINE ;- Combine proc date array and procedure array
;
N ECNT,ECPDT,ECPR,ECX,ECY
S (ECNT,ECPDT,ECX,ECY)=0,ECPR=""
F S ECX=$O(^TMP("ECPRDT",$J,ECX)) Q:'ECX D
. S ECY=0 F S ECY=$O(^TMP("ECPROC",$J,(ECY))) Q:'ECY D
.. S ECPR=$G(^TMP("ECPROC",$J,(ECY)))
.. S ECNT=ECNT+1,^TMP("ECM",$J,ECX,ECNT)=$P(ECPR,"^")_"^"_$P(ECPR,"^",2)_"^"_$P(ECPR,"^",3)_"^"_$P(ECPR,"^",4)_"^"_$P(ECPR,"^",5)
.. M ^TMP("ECM",$J,ECX,ECNT,"MOD")=^TMP("ECPROC",$J,ECY,"MOD")
Q
;
;
PRDTDEL ;- Entry point for EC MUL DEL PROCDT protocol
;
N ECDATE,ECFND,ECSEL,ECDP,VALMY
S VALMBCK=""
D FULL^VALM1
D EN^VALM2(XQORNOD(0))
S (ECFND,ECSEL)=0
F S ECSEL=$O(VALMY(ECSEL)) Q:'ECSEL D
. I $D(^TMP("ECMPIDX",$J,ECSEL)) K ECDAT S ECDAT=^(ECSEL) D
.. S ECDATE=$P(ECDAT,"^",2)
.. S ECDP=0 F S ECDP=$O(^TMP("ECPRDT",$J,ECDP)) Q:'ECDP!(ECFND) D
... I ECDATE=ECDP S ECFND=1 K ^TMP("ECPRDT",$J,ECDP)
.. I ECFND=0 W !!,*7,">>> This procedure date could not be found. <<<" D PAUSE^VALM1 Q
I '$D(^TMP("ECPRDT",$J)) K ^TMP("ECPROC",$J)
I ECFND=1 D INIT^ECMLMP
S VALMBCK="R"
K ECDAT
PRDTDLQ Q
;
;
PRDEL ;- Entry point for EC MUL PROC DEL protocol
;
N ECDP,ECFND,ECSEL,VALMY
S VALMBCK=""
D FULL^VALM1
D EN^VALM2(XQORNOD(0))
S (ECFND,ECSEL)=0
F S ECSEL=$O(VALMY(ECSEL)) Q:'ECSEL D
. I $D(^TMP("ECMPIDX",$J,ECSEL)) K ECI S ECI=^(ECSEL) D
.. S ECDP=0 F S ECDP=$O(^TMP("ECPROC",$J,ECDP)) Q:'ECDP!(ECFND) K ECN S ECN=^(ECDP) D
... I ($P(ECI,"^",3)=$P(ECN,"^")),($P(ECI,"^",4)=$P(ECN,"^",2)),($P(ECI,"^",5)=$P(ECN,"^",3)),($P(ECI,"^",6)=$P(ECN,"^",4)),($P(ECI,"^",7)=$P(ECN,"^",5)) D
.... S ECFND=1 K ^TMP("ECPROC",$J,ECDP)
.. I ECFND=0 W !!,*7,">>> This procedure could not be found. <<<" D PAUSE^VALM1 Q
I '$D(^TMP("ECPROC",$J)) K ^TMP("ECPRDT",$J)
I ECFND=1 D INIT^ECMLMP
S VALMBCK="R"
K ECI,ECN
PRDELQ Q
;
;
PRDTADD ;- Entry point for EC MUL ADD PROCDT protocol
;
N ECADD
S ECADD=0,VALMBCK=""
D FULL^VALM1
S ECADD=$$ASKPRDT^ECMUTL(+$P(ECDSSU,"^"),1)
I 'ECADD W !!,*7,">>> No Procedure Date entered. <<<" D PAUSE^VALM1 G PRDTADQ
I ECADD=1,'$D(^TMP("ECPROC",$J)) D ASKPRO^ECMUTL(ECL,+$P(ECDSSU,"^"),+$P(ECCAT,"^"),-99)
I ECADD=1,$D(^TMP("ECPROC",$J)) D INIT^ECMLMP
;
PRDTADQ S VALMBCK="R"
Q
;
;
PRADD ;- Entry point for EC MUL ADD PROC protocol
;
N ECAP
S VALMBCK=""
D FULL^VALM1
S ECAP="",ECAP=$O(^TMP("ECPROC",$J,ECAP),-1)
I ECAP>0 D
. D ASKPRO^ECMUTL(ECL,+$P(ECDSSU,"^"),+$P(ECCAT,"^"),(ECAP+1))
. D INIT^ECMLMP
I 'ECAP,('$D(^TMP("ECPRDT",$J))) W !!,*7,">>> At least one procedure date must exist before adding a procedure.",!," Please add a procedure date first. <<<" D PAUSE^VALM1
S VALMBCK="R"
PRADDQ Q
;
;
HELPTXT ; -- help text
;;Enter actions(s) by typing the name(s), or abbreviation(s).
;;
;;ACTION DEFINITIONS:
;; AD - Add a Procedure Date allows the user to add a procedure date
;; to procedures previously entered
;; DD - Delete a Procedure Date allows the user to delete a procedure
;; date from procedures previously entered
;; PA - Add a Procedure allows the user to add a procedure to all
;; procedure dates previously entered
;; PD - Delete a Procedure allows the user to delete a procedure
;; from all procedure dates previously entered
;; MP - Multiple Patients allows the user to enter the patients
;; for the indicated procedure dates and procedures
;;
;; NOTE: After the user has entered procedures and date/times, he or
;; she will need to use the 'MP' Action to add patients for the
;; entered procedures and date/times.
;;------------------------------------------------------------------------------
;;$PAUSE
;;$END