- PSJOEA1 ;BIR/MLM - INPATIENT ORDER ENTRY ; Feb 02, 2022
- ;;5.0;INPATIENT MEDICATIONS;**110,127,133,171,254,382,327,401,399,433**;16 DEC 97;Build 2
- ;
- ; Reference to ^PS(55 is supported by DBIA #2191.
- ; Reference to ^PSSLOCK is supported by DBIA #2789.
- ;
- CHK ;Check to be sure all the orders in the complex order series are completed.
- N COMQUIT,PSJCOMV,PSJOT,PSJSTAT,PSJSTAT2,PSGND2P5,DUR,ND14,PSJPREX S (PSJCOMV,COMQUIT)=0,PSJSTAT2="" K ^TMP("PSJINTER",$J)
- I '$D(^TMP("PSJCOM",$J)) Q
- N PSJO S PSJO=0 F S PSJO=$O(^PS(53.1,"ACX",PSJORD,PSJO)) Q:'PSJO Q:COMQUIT S PSJOT=$P(^PS(53.1,PSJO,0),"^",4) D
- . I '$D(^TMP("PSJCOM",$J,PSJO,0)) M ^TMP("PSJCOM",$J,PSJO)=^PS(53.1,PSJO) I '$D(^TMP("PSJCOM",$J,PSJO,0)) S COMQUIT=2 Q:COMQUIT
- . S PSJSTAT=$P(^TMP("PSJCOM",$J,PSJO,0),"^",9)
- . I PSJSTAT="DE" S PSJSTAT=$P($G(^TMP("PSJCOM2",$J,PSJO,0)),"^",9) I PSJSTAT="" S COMQUIT=1 Q
- . S:PSJSTAT2="" PSJSTAT2=PSJSTAT S:PSJSTAT'=PSJSTAT2 COMQUIT=2 Q:COMQUIT S PSJSTAT2=PSJSTAT
- I COMQUIT,PSJOT="U",$G(^TMP("PSJCOM",$J))'="A" S:$G(PSJOWALL)]"" $P(^PS(55,PSGP,5.1),U)=PSJOWALL
- I (COMQUIT=2)!(COMQUIT&($G(^TMP("PSJCOM",$J))'="A")) D Q
- .K ^TMP("PSJCOM",$J),^TMP("PSJCOM2",$J),PSGCMPLX,PSGTMPSD
- .W !,"By not finishing all the orders, none of the orders will be updated." D PAUSE^VALM1
- I 'COMQUIT N PSJO S PSJO=0 F S PSJO=$O(^TMP("PSJCOM",$J,PSJO)) Q:'PSJO D
- .S PSGS0Y=$P($G(^TMP("PSJCOM",$J,+PSJO,2)),"^",5),PSGS0XT=$P($G(^TMP("PSJCOM",$J,+PSJO,2)),"^",6)
- .N EDITS0Y,EDITS0XT S EDITS0Y=$P($G(^TMP("PSJCOM2",$J,+PSJO,2)),"^",5),EDITS0XT=$P($G(^TMP("PSJCOM2",$J,+PSJO,2)),"^",6) D
- ..S:EDITS0Y PSGS0Y=EDITS0Y I EDITS0XT!(",O,D,"[(","_EDITS0XT_",")) S PSGS0XT=EDITS0XT
- .;save the old value of indication and status before filing data to the file (#53.1) entry for this particular sub-order of the complex order
- .N PSJPRIND,PSPRSTAT S PSJPRIND=$G(^PS(53.1,+PSJO,18)),PSPRSTAT=$P($G(^PS(53.1,+PSJO,0)),U,9) ;*399-IND
- .;change the status
- .N DIE,DA,DR S DR="28////^S X=$P(^TMP(""PSJCOM"",$J,+PSJO,0),""^"",9)",DA=+PSJO,DIE="^PS(53.1," D ^DIE
- .N DIK,DA S DIK="^PS(53.1,",DA=+PSJO S:$G(DFN) DA(1)=DFN D IX^DIK K DIK,DA
- .M ^PS(53.1,+PSJO)=^TMP("PSJCOM",$J,+PSJO)
- .;the new value of indication after filing in the file (#53.1) is difefrent for this particular sub-order of the complex order
- .;then add active log entry if INDICATION has changed
- .I PSJPRIND'=$G(^PS(53.1,+PSJO,18)) D
- ..I PSPRSTAT="P"!(PSPRSTAT="N") D NEWNVAL^PSGAL5(+PSJO,6000,"INDICATION",PSJPRIND)
- ..I PSPRSTAT="U" D NEWUDAL^PSGAL5(DFN,+PSJO,6000,"INDICATION",PSJPRIND)
- .S PSGND=$G(^PS(53.1,+PSJO,0)),PSGND2P5=$G(^PS(53.1,+PSJO,2.5)),DUR=$P(PSGND2P5,"^",2),ND14=$$LASTREN^PSJLMPRI(DFN,+PSJO_"P")
- .I $P(PSGND,U,4)="U",$P(PSGND,U,24)="R" D
- ..N PND0,PSGORDR S PND0=^PS(53.1,+PSJO,0) I $P(PND0,U,24)="R" S PSGORDR=$P(PND0,U,25) D
- ...S:'$G(PSGP) PSGP=$G(DFN) Q:'$$LS^PSSLOCK(PSGP,PSGORDR)
- ...N OEORD,OOEORD,FILE55,FILE55N0,PNDP2 S PNDP2=^PS(53.1,+PSJO,.2),FILE55="^PS(55,"_DFN_$S($P(PND0,U,4)="U":",5,",1:",""IV"","),FILE55N0=FILE55_+PSGORDR_",0)"
- ...S OEORD=$P(PND0,U,21) I PSGORDR S OOEORD=$P(@FILE55N0,"^",21) I OEORD'=OOEORD D
- ....D EXPOE^PSGOER(DFN,+PSJO_"P",+$$LASTREN^PSJLMPRI(DFN,+PSJO_"P"))
- ...S PSGORDP=PSJO,DIE="^PS(53.1,",DA=+PSJO,DR="28////A;104////@" W "." D ^DIE
- ...D START^PSGOTR(+PSJO_"P",+PSGORDR) I OEORD D
- ....K DA,DR,DIE S DA(1)=DFN,DA=+PSGORDR,DIE=FILE55,DR=$S(DIE["IV":110,1:66)_"////"_+OEORD
- ....S:$P(PNDP2,U,8) DR=DR_";125////"_$P(PNDP2,U,8) D ^DIE S DIE=FILE55_+PSGORDR_",0)",$P(@DIE,U,21)=OEORD
- ....D EN1^PSJHL2(DFN,"SC",PSGORDR) ;UNL^PSSLOCK(DFN,PSGORDR) move below p433
- ..I '$G(COMQUIT) S ND14=$$LASTREN^PSJLMPRI(DFN,+PSJO_"P") I $G(ND14) S DA=+$P(PSGND,U,25) I DA D
- ...N PSGAT S PSGAT=$P($G(^TMP("PSJCOM",$J,+PSJO,2)),"^",5)
- ...D UPDREN^PSGOER(DA,$P(ND14,U),$P(ND14,U,3),$P(ND14,U,4),$P($G(^PS(53.1,+PSJO,.2)),U,3),$P(ND14,U,2))
- ...D EN1^PSJHL2(DFN,"SC",PSGORDR) ;p433
- ...N PDTYP,PSJHLDFN,RXO S PDTYP="SC",PSJHLDFN=PSGP,RXO=+PSGORDR_"U" D PDORD^PSJPDCLU ;Complex Renewals, Call PADE HL7 routine for NW Order with new OR100 ordnum-ORC.3 *401
- ...K PSJPREX I $G(PSGORDR)["U" I $G(PSJORD)=+$G(PSJORD) D CMPLX2^PSJCOM1(DFN,PSJORD,PSGORDR) I $G(PSGPXN) S PSJPREX=1
- ..D UNL^PSSLOCK(DFN,PSGORDR) ;Move unlock to here p433
- .I '$G(PSGP) S:$G(DFN) PSGP=DFN
- .I $P(PSGND,U,4)'="U",$P(PSGND,U,24)="R",$P(PSGND,U,25),$P($G(^PS(53.1,+PSJO,2)),U,2)<$P($G(^PS(55,PSGP,"IV",+$P(PSGND,U,25),0)),U,3) D
- ..K DA,DR S DA(1)=PSGP,DA=+$P(PSGND,U,25),DIE="^PS(55,"_PSGP_",""IV"",",DR=".03////"_$P($G(^PS(53.1,+PSJO,2)),U,2)_";116////"_$P($G(^PS(55,PSGP,"IV",+$P(PSGND,U,25),0)),U,3)
- ..D ^DIE,EN1^PSJHL2(PSGP,"XX",$P(PSGND,U,25)) L -^PS(53.1,+PSJO)
- .I $P(PSGND,U,9)="DE",$D(^TMP("PSJCOM2",$J,PSJO,0)),(",N,A,"[$P(^TMP("PSJCOM2",$J,PSJO,0),"^",9)) D
- ..S:'$G(PSGP) PSGP=DFN S PSGS0Y=$P($G(^TMP("PSJCOM2",$J,+PSJO,2)),"^",5)
- ..N DA,DR,DIE D ENGNN^PSGOETO S $P(^TMP("PSJCOM",$J,PSJO,0),"^",26)=DA_"P",$P(^TMP("PSJCOM2",$J,PSJO,0),"^")=DA,$P(^(0),"^",18)=DA
- ..S DR="28////^S X=$P(^TMP(""PSJCOM2"",$J,+PSJO,0),""^"",9)",DIE="^PS(53.1," D ^DIE
- ..M ^PS(53.1,DA)=^TMP("PSJCOM2",$J,+PSJO) M ^TMP("PSJCOM2",$J,DA)=^TMP("PSJCOM2",$J,+PSJO) N PSJOCHIL S PSJOCHIL=$P(^PS(53.1,DA,.2),"^",8) I PSJOCHIL S ^PS(53.1,"ACX",+PSJOCHIL,DA)=""
- ..M:$D(^TMP("PSJCOM",$J,PSJO,"DSS")) ^PS(53.1,DA,"DSS")=^TMP("PSJCOM",$J,PSJO,"DSS") ; p382 move clinic data to pending order file for corrected order
- ..I $P(^PS(53.1,+PSJO,2),"^",5)'=$P(^TMP("PSJCOM2",$J,+PSJO,2),"^",5) S $P(^PS(53.1,+PSJO,2),"^",5)=$P(^TMP("PSJCOM2",$J,+PSJO,2),"^",5)
- ..D EN1^PSJHL2(PSGP,"OD",+PSJO_"P"),EN1^PSJHL2(PSGP,"SN",+DA_"P")
- ..K ^PS(53.1,"ACX",PSJORD,PSJO) L -^PS(53.1,+PSJO) L -^PS(53.1,DA)
- ..D SETUDINT^PSGSICH1(PSJO_"P",DA_"P")
- I '$G(COMQUIT) N PSJO S PSJO=0 F S PSJO=$O(^PS(53.1,"ACX",PSJORD,PSJO)) Q:'PSJO Q:PSJCOMV D
- .I '$D(^TMP("PSJCOM",$J,PSJO)) D Q:$G(PSJCOMV)
- ..N EDITND0,PREV,REAS S EDITND0=$G(^PS(53.1,+PSJO,0)) S PREV=$P(EDITND0,"^",25),REAS=$P(EDITND0,"^",24)
- ..I PREV,REAS="E" I $P($G(^PS(53.1,+PREV,0)),"^",9)="DE" M ^TMP("PSJCOM",$J,+PSJO)=^PS(53.1,+PSJO) K ^TMP("PSJCOM",$J,+PREV),^PS(53.1,"ACX",+PREV) Q
- ..S PSJCOMV=1
- .I $P(^TMP("PSJCOM",$J,PSJO,0),"^",9)'="A",'$D(^TMP("PSJCOM2",$J,PSJO,0)) S PSJCOMV=1 Q
- .I $P($G(^TMP("PSJCOM2",$J,PSJO,0)),"^",4)="U",$P(^TMP("PSJCOM",$J,PSJO,0),"^",9)'="A",$P($G(^TMP("PSJCOM2",$J,PSJO,0)),"^",9)'="A" S PSJCOMV=1 Q
- .I $P($G(^TMP("PSJCOM2",$J,PSJO,0)),"^",4)'="U",$P(^TMP("PSJCOM",$J,PSJO,0),"^",9)'="A",$P($G(^TMP("PSJCOM2",$J,PSJO,0)),"^",17)'="A" S PSJCOMV=1
- I ($G(COMQUIT)=2)!(($G(COMQUIT)!PSJCOMV)&$G(^TMP("PSJCOM",$J))="A") K ^TMP("PSJCOM",$J),^TMP("PSJCOM2",$J) W !,"By not verifying all the orders, none of the orders will be verified." D PAUSE^VALM1 Q
- ;
- D CHK^PSJOEA2
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJOEA1 6782 printed Feb 18, 2025@23:34:34 Page 2
- PSJOEA1 ;BIR/MLM - INPATIENT ORDER ENTRY ; Feb 02, 2022
- +1 ;;5.0;INPATIENT MEDICATIONS;**110,127,133,171,254,382,327,401,399,433**;16 DEC 97;Build 2
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA #2191.
- +4 ; Reference to ^PSSLOCK is supported by DBIA #2789.
- +5 ;
- CHK ;Check to be sure all the orders in the complex order series are completed.
- +1 NEW COMQUIT,PSJCOMV,PSJOT,PSJSTAT,PSJSTAT2,PSGND2P5,DUR,ND14,PSJPREX
- SET (PSJCOMV,COMQUIT)=0
- SET PSJSTAT2=""
- KILL ^TMP("PSJINTER",$JOB)
- +2 IF '$DATA(^TMP("PSJCOM",$JOB))
- QUIT
- +3 NEW PSJO
- SET PSJO=0
- FOR
- SET PSJO=$ORDER(^PS(53.1,"ACX",PSJORD,PSJO))
- if 'PSJO
- QUIT
- if COMQUIT
- QUIT
- SET PSJOT=$PIECE(^PS(53.1,PSJO,0),"^",4)
- Begin DoDot:1
- +4 IF '$DATA(^TMP("PSJCOM",$JOB,PSJO,0))
- MERGE ^TMP("PSJCOM",$JOB,PSJO)=^PS(53.1,PSJO)
- IF '$DATA(^TMP("PSJCOM",$JOB,PSJO,0))
- SET COMQUIT=2
- if COMQUIT
- QUIT
- +5 SET PSJSTAT=$PIECE(^TMP("PSJCOM",$JOB,PSJO,0),"^",9)
- +6 IF PSJSTAT="DE"
- SET PSJSTAT=$PIECE($GET(^TMP("PSJCOM2",$JOB,PSJO,0)),"^",9)
- IF PSJSTAT=""
- SET COMQUIT=1
- QUIT
- +7 if PSJSTAT2=""
- SET PSJSTAT2=PSJSTAT
- if PSJSTAT'=PSJSTAT2
- SET COMQUIT=2
- if COMQUIT
- QUIT
- SET PSJSTAT2=PSJSTAT
- End DoDot:1
- +8 IF COMQUIT
- IF PSJOT="U"
- IF $GET(^TMP("PSJCOM",$JOB))'="A"
- if $GET(PSJOWALL)]""
- SET $PIECE(^PS(55,PSGP,5.1),U)=PSJOWALL
- +9 IF (COMQUIT=2)!(COMQUIT&($GET(^TMP("PSJCOM",$JOB))'="A"))
- Begin DoDot:1
- +10 KILL ^TMP("PSJCOM",$JOB),^TMP("PSJCOM2",$JOB),PSGCMPLX,PSGTMPSD
- +11 WRITE !,"By not finishing all the orders, none of the orders will be updated."
- DO PAUSE^VALM1
- End DoDot:1
- QUIT
- +12 IF 'COMQUIT
- NEW PSJO
- SET PSJO=0
- FOR
- SET PSJO=$ORDER(^TMP("PSJCOM",$JOB,PSJO))
- if 'PSJO
- QUIT
- Begin DoDot:1
- +13 SET PSGS0Y=$PIECE($GET(^TMP("PSJCOM",$JOB,+PSJO,2)),"^",5)
- SET PSGS0XT=$PIECE($GET(^TMP("PSJCOM",$JOB,+PSJO,2)),"^",6)
- +14 NEW EDITS0Y,EDITS0XT
- SET EDITS0Y=$PIECE($GET(^TMP("PSJCOM2",$JOB,+PSJO,2)),"^",5)
- SET EDITS0XT=$PIECE($GET(^TMP("PSJCOM2",$JOB,+PSJO,2)),"^",6)
- Begin DoDot:2
- +15 if EDITS0Y
- SET PSGS0Y=EDITS0Y
- IF EDITS0XT!(",O,D,"[(","_EDITS0XT_","))
- SET PSGS0XT=EDITS0XT
- End DoDot:2
- +16 ;save the old value of indication and status before filing data to the file (#53.1) entry for this particular sub-order of the complex order
- +17 ;*399-IND
- NEW PSJPRIND,PSPRSTAT
- SET PSJPRIND=$GET(^PS(53.1,+PSJO,18))
- SET PSPRSTAT=$PIECE($GET(^PS(53.1,+PSJO,0)),U,9)
- +18 ;change the status
- +19 NEW DIE,DA,DR
- SET DR="28////^S X=$P(^TMP(""PSJCOM"",$J,+PSJO,0),""^"",9)"
- SET DA=+PSJO
- SET DIE="^PS(53.1,"
- DO ^DIE
- +20 NEW DIK,DA
- SET DIK="^PS(53.1,"
- SET DA=+PSJO
- if $GET(DFN)
- SET DA(1)=DFN
- DO IX^DIK
- KILL DIK,DA
- +21 MERGE ^PS(53.1,+PSJO)=^TMP("PSJCOM",$JOB,+PSJO)
- +22 ;the new value of indication after filing in the file (#53.1) is difefrent for this particular sub-order of the complex order
- +23 ;then add active log entry if INDICATION has changed
- +24 IF PSJPRIND'=$GET(^PS(53.1,+PSJO,18))
- Begin DoDot:2
- +25 IF PSPRSTAT="P"!(PSPRSTAT="N")
- DO NEWNVAL^PSGAL5(+PSJO,6000,"INDICATION",PSJPRIND)
- +26 IF PSPRSTAT="U"
- DO NEWUDAL^PSGAL5(DFN,+PSJO,6000,"INDICATION",PSJPRIND)
- End DoDot:2
- +27 SET PSGND=$GET(^PS(53.1,+PSJO,0))
- SET PSGND2P5=$GET(^PS(53.1,+PSJO,2.5))
- SET DUR=$PIECE(PSGND2P5,"^",2)
- SET ND14=$$LASTREN^PSJLMPRI(DFN,+PSJO_"P")
- +28 IF $PIECE(PSGND,U,4)="U"
- IF $PIECE(PSGND,U,24)="R"
- Begin DoDot:2
- +29 NEW PND0,PSGORDR
- SET PND0=^PS(53.1,+PSJO,0)
- IF $PIECE(PND0,U,24)="R"
- SET PSGORDR=$PIECE(PND0,U,25)
- Begin DoDot:3
- +30 if '$GET(PSGP)
- SET PSGP=$GET(DFN)
- if '$$LS^PSSLOCK(PSGP,PSGORDR)
- QUIT
- +31 NEW OEORD,OOEORD,FILE55,FILE55N0,PNDP2
- SET PNDP2=^PS(53.1,+PSJO,.2)
- SET FILE55="^PS(55,"_DFN_$SELECT($PIECE(PND0,U,4)="U":",5,",1:",""IV"",")
- SET FILE55N0=FILE55_+PSGORDR_",0)"
- +32 SET OEORD=$PIECE(PND0,U,21)
- IF PSGORDR
- SET OOEORD=$PIECE(@FILE55N0,"^",21)
- IF OEORD'=OOEORD
- Begin DoDot:4
- +33 DO EXPOE^PSGOER(DFN,+PSJO_"P",+$$LASTREN^PSJLMPRI(DFN,+PSJO_"P"))
- End DoDot:4
- +34 SET PSGORDP=PSJO
- SET DIE="^PS(53.1,"
- SET DA=+PSJO
- SET DR="28////A;104////@"
- WRITE "."
- DO ^DIE
- +35 DO START^PSGOTR(+PSJO_"P",+PSGORDR)
- IF OEORD
- Begin DoDot:4
- +36 KILL DA,DR,DIE
- SET DA(1)=DFN
- SET DA=+PSGORDR
- SET DIE=FILE55
- SET DR=$SELECT(DIE["IV":110,1:66)_"////"_+OEORD
- +37 if $PIECE(PNDP2,U,8)
- SET DR=DR_";125////"_$PIECE(PNDP2,U,8)
- DO ^DIE
- SET DIE=FILE55_+PSGORDR_",0)"
- SET $PIECE(@DIE,U,21)=OEORD
- +38 ;UNL^PSSLOCK(DFN,PSGORDR) move below p433
- DO EN1^PSJHL2(DFN,"SC",PSGORDR)
- End DoDot:4
- End DoDot:3
- +39 IF '$GET(COMQUIT)
- SET ND14=$$LASTREN^PSJLMPRI(DFN,+PSJO_"P")
- IF $GET(ND14)
- SET DA=+$PIECE(PSGND,U,25)
- IF DA
- Begin DoDot:3
- +40 NEW PSGAT
- SET PSGAT=$PIECE($GET(^TMP("PSJCOM",$JOB,+PSJO,2)),"^",5)
- +41 DO UPDREN^PSGOER(DA,$PIECE(ND14,U),$PIECE(ND14,U,3),$PIECE(ND14,U,4),$PIECE($GET(^PS(53.1,+PSJO,.2)),U,3),$PIECE(ND14,U,2))
- +42 ;p433
- DO EN1^PSJHL2(DFN,"SC",PSGORDR)
- +43 ;Complex Renewals, Call PADE HL7 routine for NW Order with new OR100 ordnum-ORC.3 *401
- NEW PDTYP,PSJHLDFN,RXO
- SET PDTYP="SC"
- SET PSJHLDFN=PSGP
- SET RXO=+PSGORDR_"U"
- DO PDORD^PSJPDCLU
- +44 KILL PSJPREX
- IF $GET(PSGORDR)["U"
- IF $GET(PSJORD)=+$GET(PSJORD)
- DO CMPLX2^PSJCOM1(DFN,PSJORD,PSGORDR)
- IF $GET(PSGPXN)
- SET PSJPREX=1
- End DoDot:3
- +45 ;Move unlock to here p433
- DO UNL^PSSLOCK(DFN,PSGORDR)
- End DoDot:2
- +46 IF '$GET(PSGP)
- if $GET(DFN)
- SET PSGP=DFN
- +47 IF $PIECE(PSGND,U,4)'="U"
- IF $PIECE(PSGND,U,24)="R"
- IF $PIECE(PSGND,U,25)
- IF $PIECE($GET(^PS(53.1,+PSJO,2)),U,2)<$PIECE($GET(^PS(55,PSGP,"IV",+$PIECE(PSGND,U,25),0)),U,3)
- Begin DoDot:2
- +48 KILL DA,DR
- SET DA(1)=PSGP
- SET DA=+$PIECE(PSGND,U,25)
- SET DIE="^PS(55,"_PSGP_",""IV"","
- SET DR=".03////"_$PIECE($GET(^PS(53.1,+PSJO,2)),U,2)_";116////"_$PIECE($GET(^PS(55,PSGP,"IV",+$PIECE(PSGND,U,25),0)),U,3)
- +49 DO ^DIE
- DO EN1^PSJHL2(PSGP,"XX",$PIECE(PSGND,U,25))
- LOCK -^PS(53.1,+PSJO)
- End DoDot:2
- +50 IF $PIECE(PSGND,U,9)="DE"
- IF $DATA(^TMP("PSJCOM2",$JOB,PSJO,0))
- IF (",N,A,"[$PIECE(^TMP("PSJCOM2",$JOB,PSJO,0),"^",9))
- Begin DoDot:2
- +51 if '$GET(PSGP)
- SET PSGP=DFN
- SET PSGS0Y=$PIECE($GET(^TMP("PSJCOM2",$JOB,+PSJO,2)),"^",5)
- +52 NEW DA,DR,DIE
- DO ENGNN^PSGOETO
- SET $PIECE(^TMP("PSJCOM",$JOB,PSJO,0),"^",26)=DA_"P"
- SET $PIECE(^TMP("PSJCOM2",$JOB,PSJO,0),"^")=DA
- SET $PIECE(^(0),"^",18)=DA
- +53 SET DR="28////^S X=$P(^TMP(""PSJCOM2"",$J,+PSJO,0),""^"",9)"
- SET DIE="^PS(53.1,"
- DO ^DIE
- +54 MERGE ^PS(53.1,DA)=^TMP("PSJCOM2",$JOB,+PSJO)
- MERGE ^TMP("PSJCOM2",$JOB,DA)=^TMP("PSJCOM2",$JOB,+PSJO)
- NEW PSJOCHIL
- SET PSJOCHIL=$PIECE(^PS(53.1,DA,.2),"^",8)
- IF PSJOCHIL
- SET ^PS(53.1,"ACX",+PSJOCHIL,DA)=""
- +55 ; p382 move clinic data to pending order file for corrected order
- if $DATA(^TMP("PSJCOM",$JOB,PSJO,"DSS"))
- MERGE ^PS(53.1,DA,"DSS")=^TMP("PSJCOM",$JOB,PSJO,"DSS")
- +56 IF $PIECE(^PS(53.1,+PSJO,2),"^",5)'=$PIECE(^TMP("PSJCOM2",$JOB,+PSJO,2),"^",5)
- SET $PIECE(^PS(53.1,+PSJO,2),"^",5)=$PIECE(^TMP("PSJCOM2",$JOB,+PSJO,2),"^",5)
- +57 DO EN1^PSJHL2(PSGP,"OD",+PSJO_"P")
- DO EN1^PSJHL2(PSGP,"SN",+DA_"P")
- +58 KILL ^PS(53.1,"ACX",PSJORD,PSJO)
- LOCK -^PS(53.1,+PSJO)
- LOCK -^PS(53.1,DA)
- +59 DO SETUDINT^PSGSICH1(PSJO_"P",DA_"P")
- End DoDot:2
- End DoDot:1
- +60 IF '$GET(COMQUIT)
- NEW PSJO
- SET PSJO=0
- FOR
- SET PSJO=$ORDER(^PS(53.1,"ACX",PSJORD,PSJO))
- if 'PSJO
- QUIT
- if PSJCOMV
- QUIT
- Begin DoDot:1
- +61 IF '$DATA(^TMP("PSJCOM",$JOB,PSJO))
- Begin DoDot:2
- +62 NEW EDITND0,PREV,REAS
- SET EDITND0=$GET(^PS(53.1,+PSJO,0))
- SET PREV=$PIECE(EDITND0,"^",25)
- SET REAS=$PIECE(EDITND0,"^",24)
- +63 IF PREV
- IF REAS="E"
- IF $PIECE($GET(^PS(53.1,+PREV,0)),"^",9)="DE"
- MERGE ^TMP("PSJCOM",$JOB,+PSJO)=^PS(53.1,+PSJO)
- KILL ^TMP("PSJCOM",$JOB,+PREV),^PS(53.1,"ACX",+PREV)
- QUIT
- +64 SET PSJCOMV=1
- End DoDot:2
- if $GET(PSJCOMV)
- QUIT
- +65 IF $PIECE(^TMP("PSJCOM",$JOB,PSJO,0),"^",9)'="A"
- IF '$DATA(^TMP("PSJCOM2",$JOB,PSJO,0))
- SET PSJCOMV=1
- QUIT
- +66 IF $PIECE($GET(^TMP("PSJCOM2",$JOB,PSJO,0)),"^",4)="U"
- IF $PIECE(^TMP("PSJCOM",$JOB,PSJO,0),"^",9)'="A"
- IF $PIECE($GET(^TMP("PSJCOM2",$JOB,PSJO,0)),"^",9)'="A"
- SET PSJCOMV=1
- QUIT
- +67 IF $PIECE($GET(^TMP("PSJCOM2",$JOB,PSJO,0)),"^",4)'="U"
- IF $PIECE(^TMP("PSJCOM",$JOB,PSJO,0),"^",9)'="A"
- IF $PIECE($GET(^TMP("PSJCOM2",$JOB,PSJO,0)),"^",17)'="A"
- SET PSJCOMV=1
- End DoDot:1
- +68 IF ($GET(COMQUIT)=2)!(($GET(COMQUIT)!PSJCOMV)&$GET(^TMP("PSJCOM",$JOB))="A")
- KILL ^TMP("PSJCOM",$JOB),^TMP("PSJCOM2",$JOB)
- WRITE !,"By not verifying all the orders, none of the orders will be verified."
- DO PAUSE^VALM1
- QUIT
- +69 ;
- +70 DO CHK^PSJOEA2
- +71 QUIT