- 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 Feb 18, 2025@23:24:08 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