210 lines
7.2 KiB
Mathematica
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
|