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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECMLMP 7580 printed Dec 13, 2024@01:57:45 Page 2
ECMLMP ;ALB/ESD - Multiple procedure dates and procedures ;22 AUG 1997 11:11
+1 ;;2.0; EVENT CAPTURE ;**5,18,47**;8 May 96
+2 ;
EN ;- ListMan entry point
+1 ;
+2 DO EN^VALM("EC MUL PROCEDURES")
+3 QUIT
+4 ;
HDR ;- Display location, provider #1, DSS Unit, and Category as header
+1 ;
+2 SET VALMHDR(1)=" Location: "_$GET(ECLN)_" ("_$GET(ECL)_")"
+3 SET VALMHDR(1)=$$SETSTR^VALM1("Provider #1: "_$PIECE(ECU(1),"^",2),VALMHDR(1),40,30)
+4 SET VALMHDR(2)=" DSS Unit: "_$PIECE(ECDSSU,"^",2)
+5 SET VALMHDR(2)=$$SETSTR^VALM1(" Category: "_$PIECE(ECCAT,"^",2),VALMHDR(2),40,30)
+6 ;
+7 QUIT
+8 ;
INIT ;- Initialize variables and call BLD which does processing
+1 ;
+2 NEW BL,ECPCNT,IC,IW,DC,DW,NC,NW,PC,PW,RC,RW,VC,VW,X,MC,MW
+3 DO CLEAN^VALM10
+4 KILL ^TMP("ECM",$JOB),^TMP("ECMP",$JOB),^TMP("ECMPIDX",$JOB)
+5 ;K XQORNOD,%B
+6 ;
+7 SET (VALMCNT,ECPCNT)=0
+8 SET BL=""
SET $PIECE(BL," ",30)=""
+9 SET X=VALMDDF("INDEX")
SET IC=$PIECE(X,"^",2)
SET IW=$PIECE(X,"^",3)
+10 SET X=VALMDDF("PROC DT")
SET DC=$PIECE(X,"^",2)
SET DW=$PIECE(X,"^",3)
+11 SET X=VALMDDF("PROC NUM")
SET NC=$PIECE(X,"^",2)
SET NW=$PIECE(X,"^",3)
+12 SET X=VALMDDF("PROCEDURE")
SET PC=$PIECE(X,"^",2)
SET PW=$PIECE(X,"^",3)
+13 SET X=VALMDDF("VOL")
SET VC=$PIECE(X,"^",2)
SET VW=$PIECE(X,"^",3)
+14 SET X=VALMDDF("REASON")
SET RC=$PIECE(X,"^",2)
SET RW=$PIECE(X,"^",3)
+15 SET X=VALMDDF("MODIFIER")
SET MC=$PIECE(X,"^",2)
SET MW=$PIECE(X,"^",3)
+16 ;
+17 DO BLD
+18 SET $PIECE(^TMP("ECMP",$JOB,0),"^",4)=VALMCNT
+19 QUIT
+20 ;
BLD ;- Combine arrays and build lines with data for display
+1 ;
+2 DO COMBINE
+3 ;
+4 NEW ECPD,ECNT,ECX
+5 SET ECPD=0
FOR
SET ECPD=$ORDER(^TMP("ECM",$JOB,ECPD))
if 'ECPD
QUIT
Begin DoDot:1
+6 SET ECNT=0
FOR
SET ECNT=$ORDER(^TMP("ECM",$JOB,ECPD,ECNT))
if 'ECNT
QUIT
DO BLDLM
End DoDot:1
+7 ;
+8 QUIT
+9 ;
BLDLM ;- Build each line for display and create ^TMP("ECMPIDX",$J) array
+1 ;
+2 NEW ECPR,ECCPT
KILL ECX
+3 SET ECPCNT=ECPCNT+1
SET ECX=""
SET $PIECE(ECX," ",VALMWD+1)=""
+4 SET ECX=$EXTRACT(ECX,1,IC-1)_$EXTRACT(ECPCNT_BL,1,IW)_$EXTRACT(ECX,IC+IW+1,VALMWD)
+5 SET ECX=$EXTRACT(ECX,1,DC-1)_$EXTRACT($$FTIME^VALM1(ECPD)_BL,1,DW)_$EXTRACT(ECX,DC+DW+1,VALMWD)
+6 SET ECX=$EXTRACT(ECX,1,NC-1)_$EXTRACT($PIECE($PIECE(^TMP("ECM",$JOB,ECPD,ECNT),"^"),";")_BL,1,NW)_$EXTRACT(ECX,NC+NW+1,VALMWD)
+7 SET ECCPT=$PIECE(^TMP("ECM",$JOB,ECPD,ECNT),"^")
+8 SET ECCPT=$SELECT(ECCPT["ICPT":+ECCPT,1:$PIECE($GET(^EC(725,+ECCPT,0)),"^",5))
+9 IF ECCPT'=""
SET ECCPT=$PIECE($$CPT^ICPTCOD(ECCPT,ECPD),U,2)
+10 SET ECPR=$SELECT(ECCPT'="":ECCPT_" ",1:ECCPT)_$PIECE(^TMP("ECM",$JOB,ECPD,ECNT),"^",2)
+11 SET ECX=$EXTRACT(ECX,1,PC-1)_$EXTRACT($EXTRACT(ECPR,1,30)_BL,1,PW)_$EXTRACT(ECX,PC+PW+1,VALMWD)
+12 SET ECX=$EXTRACT(ECX,1,VC-1)_$EXTRACT($PIECE(^TMP("ECM",$JOB,ECPD,ECNT),"^",5)_BL,1,VW)_$EXTRACT(ECX,VC+VW+1,VALMWD)
+13 ;
+14 DO SET(ECX)
+15 ;
+16 SET ^TMP("ECMPIDX",$JOB,ECPCNT)=VALMCNT_"^"_ECPD_"^"_$PIECE(^TMP("ECM",$JOB,ECPD,ECNT),"^")_"^"_$PIECE(^TMP("ECM",...
... $JOB,ECPD,ECNT),"^",2)_"^"_$PIECE(^TMP("ECM",$JOB,ECPD,ECNT),"^",3)_"^"_$PIECE(^TMP("ECM",$JOB,ECPD,ECNT),"^",4)_"^"_$PIECE(^TMP("ECM",$JOB,ECPD,ECNT),"^",5)
+17 ;
+18 IF $DATA(^TMP("ECM",$JOB,ECPD,ECNT,"MOD"))
Begin DoDot:1
+19 SET MOD=""
SET ECX=$EXTRACT(BL,1,26)_"Modifier:"
+20 FOR
SET MOD=$ORDER(^TMP("ECM",$JOB,ECPD,ECNT,"MOD",MOD))
if MOD=""
QUIT
Begin DoDot:2
+21 SET ECX=$EXTRACT(ECX,1,MC-1)_" - "_MOD_" "_$EXTRACT($PIECE(^TMP("ECM",$JOB,ECPD,ECNT,"MOD",MOD),"^")_BL,1,MW)_$EXTRACT(ECX,MC+MW+1,VALMWD)
+22 DO SET(ECX)
KILL ECX
SET ECX=BL_" "
End DoDot:2
+23 MERGE ^TMP("ECMPIDX",$JOB,ECPCNT,"MOD")=^TMP("ECM",$JOB,ECPD,ECNT,"MOD")
End DoDot:1
KILL MOD
+24 ;
+25 KILL ECX
+26 SET ECX=" "
+27 SET ECX=$EXTRACT(ECX,1,RC-1)_"Procedure Reason: "_$EXTRACT($PIECE(^TMP("ECM",$JOB,ECPD,ECNT),"^",4)_BL,1,RW)_$EXTRACT(ECX,RC+RW+1,VALMWD)
+28 DO SET(ECX)
+29 KILL ECX
SET ECX=BL
DO SET(ECX)
+30 QUIT
+31 ;
+32 ;
SET(X) ;- Create display array ^TMP("ECMP",$J)
+1 ;
+2 SET VALMCNT=VALMCNT+1
SET ^TMP("ECMP",$JOB,VALMCNT,0)=X
+3 SET ^TMP("ECMP",$JOB,"IDX",VALMCNT,ECPCNT)=""
+4 QUIT
+5 ;
HLPS ;- Brief help
+1 ;
+2 SET X="?"
DO DISP^XQORM1
WRITE !!
+3 QUIT
HELP ;- Help for list
+1 SET ECZ=""
+2 IF $DATA(X)
IF X'["??"
DO HLPS
DO PAUSE^VALM1
GOTO HLPQ
+3 DO CLEAR^VALM1
+4 FOR I=1:1
SET ECZ=$PIECE($TEXT(HELPTXT+I),";",3,99)
if ECZ="$END"
QUIT
if ECZ="$PAUSE"
DO PAUSE^VALM1
if 'Y
QUIT
WRITE !,$SELECT(ECZ["$PAUSE":"",1:ECZ)
+5 WRITE !,"Possible actions are the following:"
+6 DO HLPS
DO PAUSE^VALM1
SET VALMBCK="R"
HLPQ KILL ECZ,Y,I
QUIT
+1 ;
EXIT ;- Clean up and exit
+1 ;
+2 KILL ^TMP("ECPRDT",$JOB),^TMP("ECPROC",$JOB)
+3 KILL ^TMP("ECM",$JOB),^TMP("ECMP",$JOB)
+4 KILL VALMDDF
+5 DO CLEAN^VALM10
DO CLEAR^VALM1
+6 QUIT
+7 ;
COMBINE ;- Combine proc date array and procedure array
+1 ;
+2 NEW ECNT,ECPDT,ECPR,ECX,ECY
+3 SET (ECNT,ECPDT,ECX,ECY)=0
SET ECPR=""
+4 FOR
SET ECX=$ORDER(^TMP("ECPRDT",$JOB,ECX))
if 'ECX
QUIT
Begin DoDot:1
+5 SET ECY=0
FOR
SET ECY=$ORDER(^TMP("ECPROC",$JOB,(ECY)))
if 'ECY
QUIT
Begin DoDot:2
+6 SET ECPR=$GET(^TMP("ECPROC",$JOB,(ECY)))
+7 SET ECNT=ECNT+1
SET ^TMP("ECM",$JOB,ECX,ECNT)=$PIECE(ECPR,"^")_"^"_$PIECE(ECPR,"^",2)_"^"_$PIECE(ECPR,"^",3)_"^"_$PIECE(ECPR,"^",4)_"^"_$PIECE(ECPR,"^",5)
+8 MERGE ^TMP("ECM",$JOB,ECX,ECNT,"MOD")=^TMP("ECPROC",$JOB,ECY,"MOD")
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
+11 ;
PRDTDEL ;- Entry point for EC MUL DEL PROCDT protocol
+1 ;
+2 NEW ECDATE,ECFND,ECSEL,ECDP,VALMY
+3 SET VALMBCK=""
+4 DO FULL^VALM1
+5 DO EN^VALM2(XQORNOD(0))
+6 SET (ECFND,ECSEL)=0
+7 FOR
SET ECSEL=$ORDER(VALMY(ECSEL))
if 'ECSEL
QUIT
Begin DoDot:1
+8 IF $DATA(^TMP("ECMPIDX",$JOB,ECSEL))
KILL ECDAT
SET ECDAT=^(ECSEL)
Begin DoDot:2
+9 SET ECDATE=$PIECE(ECDAT,"^",2)
+10 SET ECDP=0
FOR
SET ECDP=$ORDER(^TMP("ECPRDT",$JOB,ECDP))
if 'ECDP!(ECFND)
QUIT
Begin DoDot:3
+11 IF ECDATE=ECDP
SET ECFND=1
KILL ^TMP("ECPRDT",$JOB,ECDP)
End DoDot:3
+12 IF ECFND=0
WRITE !!,*7,">>> This procedure date could not be found. <<<"
DO PAUSE^VALM1
QUIT
End DoDot:2
End DoDot:1
+13 IF '$DATA(^TMP("ECPRDT",$JOB))
KILL ^TMP("ECPROC",$JOB)
+14 IF ECFND=1
DO INIT^ECMLMP
+15 SET VALMBCK="R"
+16 KILL ECDAT
PRDTDLQ QUIT
+1 ;
+2 ;
PRDEL ;- Entry point for EC MUL PROC DEL protocol
+1 ;
+2 NEW ECDP,ECFND,ECSEL,VALMY
+3 SET VALMBCK=""
+4 DO FULL^VALM1
+5 DO EN^VALM2(XQORNOD(0))
+6 SET (ECFND,ECSEL)=0
+7 FOR
SET ECSEL=$ORDER(VALMY(ECSEL))
if 'ECSEL
QUIT
Begin DoDot:1
+8 IF $DATA(^TMP("ECMPIDX",$JOB,ECSEL))
KILL ECI
SET ECI=^(ECSEL)
Begin DoDot:2
+9 SET ECDP=0
FOR
SET ECDP=$ORDER(^TMP("ECPROC",$JOB,ECDP))
if 'ECDP!(ECFND)
QUIT
KILL ECN
SET ECN=^(ECDP)
Begin DoDot:3
+10 IF ($PIECE(ECI,"^",3)=$PIECE(ECN,"^"))
IF ($PIECE(ECI,"^",4)=$PIECE(ECN,"^",2))
IF ($PIECE(ECI,"^",5)=$PIECE(ECN,"^",3))
IF ($PIECE(ECI,"^",6)=$PIECE(ECN,"^",4))
IF ($PIECE(ECI,"^",7)=$PIECE(ECN,"^",5))
Begin DoDot:4
+11 SET ECFND=1
KILL ^TMP("ECPROC",$JOB,ECDP)
End DoDot:4
End DoDot:3
+12 IF ECFND=0
WRITE !!,*7,">>> This procedure could not be found. <<<"
DO PAUSE^VALM1
QUIT
End DoDot:2
End DoDot:1
+13 IF '$DATA(^TMP("ECPROC",$JOB))
KILL ^TMP("ECPRDT",$JOB)
+14 IF ECFND=1
DO INIT^ECMLMP
+15 SET VALMBCK="R"
+16 KILL ECI,ECN
PRDELQ QUIT
+1 ;
+2 ;
PRDTADD ;- Entry point for EC MUL ADD PROCDT protocol
+1 ;
+2 NEW ECADD
+3 SET ECADD=0
SET VALMBCK=""
+4 DO FULL^VALM1
+5 SET ECADD=$$ASKPRDT^ECMUTL(+$PIECE(ECDSSU,"^"),1)
+6 IF 'ECADD
WRITE !!,*7,">>> No Procedure Date entered. <<<"
DO PAUSE^VALM1
GOTO PRDTADQ
+7 IF ECADD=1
IF '$DATA(^TMP("ECPROC",$JOB))
DO ASKPRO^ECMUTL(ECL,+$PIECE(ECDSSU,"^"),+$PIECE(ECCAT,"^"),-99)
+8 IF ECADD=1
IF $DATA(^TMP("ECPROC",$JOB))
DO INIT^ECMLMP
+9 ;
PRDTADQ SET VALMBCK="R"
+1 QUIT
+2 ;
+3 ;
PRADD ;- Entry point for EC MUL ADD PROC protocol
+1 ;
+2 NEW ECAP
+3 SET VALMBCK=""
+4 DO FULL^VALM1
+5 SET ECAP=""
SET ECAP=$ORDER(^TMP("ECPROC",$JOB,ECAP),-1)
+6 IF ECAP>0
Begin DoDot:1
+7 DO ASKPRO^ECMUTL(ECL,+$PIECE(ECDSSU,"^"),+$PIECE(ECCAT,"^"),(ECAP+1))
+8 DO INIT^ECMLMP
End DoDot:1
+9 IF 'ECAP
IF ('$DATA(^TMP("ECPRDT",$JOB)))
WRITE !!,*7,">>> At least one procedure date must exist before adding a procedure.",!," Please add a procedure date first. <<<"
DO PAUSE^VALM1
+10 SET VALMBCK="R"
PRADDQ QUIT
+1 ;
+2 ;
HELPTXT ; -- help text
+1 ;;Enter actions(s) by typing the name(s), or abbreviation(s).
+2 ;;
+3 ;;ACTION DEFINITIONS:
+4 ;; AD - Add a Procedure Date allows the user to add a procedure date
+5 ;; to procedures previously entered
+6 ;; DD - Delete a Procedure Date allows the user to delete a procedure
+7 ;; date from procedures previously entered
+8 ;; PA - Add a Procedure allows the user to add a procedure to all
+9 ;; procedure dates previously entered
+10 ;; PD - Delete a Procedure allows the user to delete a procedure
+11 ;; from all procedure dates previously entered
+12 ;; MP - Multiple Patients allows the user to enter the patients
+13 ;; for the indicated procedure dates and procedures
+14 ;;
+15 ;; NOTE: After the user has entered procedures and date/times, he or
+16 ;; she will need to use the 'MP' Action to add patients for the
+17 ;; entered procedures and date/times.
+18 ;;------------------------------------------------------------------------------
+19 ;;$PAUSE
+20 ;;$END
