- PSJOEA ;BIR/MLM-INPATIENT ORDER ENTRY ;12 June 2019 09:31:53
- ;;5.0;INPATIENT MEDICATIONS;**110,127,133,167,171,254,315,367,327**;16 DEC 97;Build 114
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ; Reference to ^PS(55 via DBIA #2191
- ; Reference to EN^VALM via DBIA #10118
- ; Reference to ^PSSLOCK via DBIA #2789
- ; Reference to ^DPT via DBIA #10035
- ; Reference to SDIMO^SDAMA203 via DBIA #4133
- ;
- LOCK(DFN,PSJORD) ; Check if the order is locked
- N Q S Q=0
- I PSJORD=+PSJORD N PSJO S PSJO=0 F S PSJO=$O(^PS(53.1,"ACX",PSJORD,PSJO)) Q:'PSJO S Q=$$LS^PSSLOCK(DFN,PSJO_"P") I 'Q Q
- I Q Q 1
- Q 0
- ;
- SELECT ;
- N PSJCLIN,O
- Q:PSJORD=""!($G(Y)<0) Q:('$$LOCK^PSJOEA(PSGP,PSJORD))
- N PSJO S PSJO=0 F S PSJO=$O(^PS(53.1,"ACX",PSJORD,PSJO)) Q:'PSJO D
- .S PSGORD="" S ON=PSJO_"P"
- .D DISACTIO(PSGP,PSJO_"P",$G(PSJPNV)) S:$G(PSJO)["V" O=ON
- K PSGCOMP,PSGFLG ; CLEAN UP VARIABLE FOR COMPLEX ORDER MESSAGE RJS*327
- I $D(^TMP("PSJCOM",$J)) D CHK^PSJOEA1
- S:'$G(PSGP) PSGP=$G(DFN)
- N PSJO S PSJO=0 F S PSJO=$O(^PS(53.1,"ACX",PSJORD,PSJO)) Q:'PSJO D
- .L -^PS(53.1,PSJO) ; p367
- .D UNL^PSSLOCK(PSGP,PSJO_"P") ; Q:$G(Y)<0 p367 commented quit out
- ; p367 Unlock complex orders (file 100) after verification of all child orders in the complex order.
- N PSJO S PSJO=0 F S PSJO=$O(^TMP("PSJCVFY",$J,PSJO)) Q:'PSJO D
- .N PSJIDX S PSJIDX=$G(^TMP("PSJCVFY",$J,PSJO))
- .D UNL^PSSLOCK(PSGP,PSJIDX) K ^TMP("PSJCVFY",$J,PSJO),PSJIDX
- D DONE
- Q
- ;
- DISACTIO(DFN,PSJORD,PSJPNV) ; Display UD order and allow actions.
- ; DFN - Patient IEN
- ; PSJORD - Order #_location Code (P:53.1,V:55.01,U:55.06)
- ; PSJPNV - Invoked from Pending/NV option; (gets different hidden menu)
- N PSGP,PSJIVFLG,PSGSDX,PSGFDX,PSJXX1,ON55,PSJAPPT
- Q:PSJORD'["P"
- Q:$G(PSJCLIN)=-2
- S PSGP=DFN D ENIV^PSJAC
- D GETUD^PSJLMGUD(DFN,PSJORD)
- S PSGOEAV=$P(PSJSYSP0,"^",9)&PSJSYSU
- S:$G(PSJTUD) PSGPD=$G(PSJCOI),PSGPDN=$$OINAME^PSJLMUTL(+PSGPD)
- K PSGOENG I '$D(PSGPRF) D Q:$G(PSGOENG)
- . I PSJORD["P" L +^PS(53.1,+PSJORD):1 E S PSGOENG=1
- . I $G(PSGOENG) W !,"This order is being edited by another terminal.",! S PSGOENG=1 K DIR S DIR(0)="E" D ^DIR K DIR Q
- S PSGACT=$$ENACTION^PSGOE1(PSGP,PSJORD)
- I PSJORD["P" S PSJXX1=$G(^PS(53.1,+PSJORD,0)) I PSGP'=$P(PSJXX1,U,15)!(DFN'=$P(PSJXX1,U,15)) Q ;L -^PS(53.1,+PSJORD) Q
- I PSJORD["P" D S PSJXX1=$P($G(^PS(53.1,+PSJORD,0)),U,9) I $S($G(PSJIVFLG):1,$G(Y)<0:1,"PADE"[PSJXX1:1,1:0) Q ;L -^PS(53.1,+PSJORD) Q
- .I $P(PSJXX1,U,9)="N",($P(PSJXX1,U,4)'="U") D Q
- .. S P("PON")=PSJORD,PSIVFLG=1
- .. D GT531^PSIVORFA(+PSGP,PSJORD),VF^PSIVORC2
- .I $P(PSJXX1,U,9)="P" D Q
- ..S:$G(PSJTUD) $P(PSJXX1,U,4)="U"
- ..N VAIP S PSJCLIN=$G(^PS(53.1,+PSJORD,"DSS")),PSJAPPT=$P(PSJCLIN,"^",2),PSJCLIN=$P(PSJCLIN,"^")
- ..I $P(PSJXX1,U,4)="U",(+PSJPDD) D Q:(PSJCLIN=-2)
- ...I $$PATCH^XPDUTL("SD*5.3*285"),($$SDIMO^SDAMA203(PSJCLIN,DFN)>-1) Q
- ...W !!,"Cannot process an Out-patient Unit Dose order for ",$P($G(^DPT(+PSGP,0)),U) D PAUSE^VALM1 S PSJIVFLG=1,PSJCLIN=-2
- ..NEW PSGRSD,PSGRSDN,PSGRFD,PSGRFDN
- ..D REQDT^PSJLIVMD(PSJORD)
- ..I $P(PSJXX1,U,4)="U",($G(PSGSCH)="") W !!,"Invalid schedule, can't finish this order" D PAUSE^VALM1 Q
- ..I $P(PSJXX1,U,4)="U" N PSJLM S PSJLM=1,PSGORD=PSJORD D START^PSGOEF,ENSFE^PSGOEE0(PSGP,PSGORD),@$S($G(PSJTUD):"FINISH^PSGOEF",1:"EN^VALM(""PSJ LM PENDING EDIT"")") D Q
- ...K ^TMP("PSJINTER",$J),PSJOVR
- ..I $P(PSJXX1,U,4)'="U",PSGP=$P(PSJXX1,U,15),DFN=$P(PSJXX1,U,15) S PSJLYN=PSJORD D EN^PSJLIFN S PSJIVFLG=1 K PSJLYN,PSJMAI
- I $G(PSIVFLG) K PSIVFLG Q
- S PSGACT=$$ENACTION^PSGOE1(PSGP,PSJORD),PSGOEEF=0 D GETUD^PSJLMGUD(PSGP,PSJORD),ENSFE^PSGOEE0(PSGP,PSJORD),EN^VALM("PSJ LM UD ACTION")
- ;Send SN to CPRS if autoverify OFF and Order Set Entry and no 21st piece
- I $D(PSGOES),'PSGOEAV,$D(PSGORD),PSGORD["P",$P($G(^PS(53.1,+PSGORD,0)),"^",21)']"" D ORSET^PSGOETO1
- Q
- ;
- ACTLOG(PSGORDP,DFN,PSGORD) ;Store 53.1 activity log in local array to be moved to 55
- ;PSGORDP: IEN from 53.1
- ;PSGORD : IEN from 55
- NEW PSGX,PSGXDA,PSGAL531,Q,QQ
- F PSGX=0:0 S PSGX=$O(^PS(53.1,+PSGORDP,"A",PSGX)) Q:'PSGX D
- . S PSGAL531=$G(^PS(53.1,+PSGORDP,"A",PSGX,0))
- . S QQ=$G(^PS(55,DFN,5,+PSGORD,9,0)) S:QQ="" QQ="^55.09D" F Q=$P(QQ,U,3)+1:1 I '$D(^(Q)) S $P(QQ,U,3,4)=Q_U_Q,^(0)=QQ,PSGXDA=Q Q
- . S ^PS(55,DFN,5,+PSGORD,9,PSGXDA,0)=PSGAL531
- Q
- ;
- UD ;
- N DA,DR,DIE,PSJCMPDA D ENGNA^PSGOETO S $P(^TMP("PSJCOM",$J,PSJO,0),"^",26)=DA_"U",$P(^TMP("PSJCOM2",$J,PSJO,0),"^")=DA,$P(^(0),"^",18)=DA S PSJCMPDA=DA
- M ^PS(55,PSGP,5,DA)=^TMP("PSJCOM2",$J,+PSJO) M ^PS(53.1,+PSJO)=^TMP("PSJCOM",$J,+PSJO) D EN1^PSJHL2(PSGP,"OD",+PSJO_"P") S PSJNOO=$P(^TMP("PSJCOM2",$J,+PSJO,.2),U,3) D EN1^PSJHL2(PSGP,"SN",+PSJCMPDA_"U")
- N PSGPDRG,PSGST,PSGNESD,PSGNEFD,ND2,ND2P1
- S PSGPDRG=$P($G(^PS(55,PSGP,5,PSJCMPDA,.2)),"^"),PSGST=$P($G(^PS(55,PSGP,5,PSJCMPDA,0)),"^",7)
- S ND2=$G(^PS(55,PSGP,5,PSJCMPDA,2)),PSGNESD=$P(ND2,"^",2),PSGNEFD=$P(ND2,"^",4) D CRA^PSGOETO
- S ND2P1=$G(^PS(55,PSGP,5,PSJCMPDA,2)),PSGRMVT=$P(ND2P1,"^",2) ;*315
- K ^PS(53.1,"ACX",PSJORD,PSJO) K PSJPREX
- I $G(PSJCMPDA) D CMPLX2^PSJCOM1(PSGP,PSJORD,+PSJCMPDA_"U") I $G(PSGPXN) S PSJPREX=1
- Q
- IV ;
- K ON55 I $P($G(^PS(53.1,+PSJO,0)),"^",24)="R",$P($G(^PS(53.1,+PSJO,0)),"^",25) S ON55=$P(^PS(53.1,+PSJO,0),"^",25)
- I '$G(ON55) D NEW55^PSIVORFB
- S $P(^TMP("PSJCOM",$J,PSJO,0),"^",26)=ON55,$P(^TMP("PSJCOM2",$J,PSJO,0),"^")=+ON55
- S $P(^TMP("PSJCOM2",$J,PSJO,2),U,5)=PSJO_"P",$P(^TMP("PSJCOM",$J,PSJO,0),U,26)=ON55
- M ^PS(55,DFN,"IV",+ON55)=^TMP("PSJCOM2",$J,+PSJO) M ^PS(53.1,+PSJO)=^TMP("PSJCOM",$J,+PSJO) D EN1^PSJHL2(PSGP,"OD",+PSJO_"P") S P("NAT")=$P(^TMP("PSJCOM2",$J,+PSJO,.2),U,5) D EN1^PSJHL2(PSGP,"SN",ON55)
- K DA,DIK S DA(1)=DFN,DA=+ON55,DIK="^PS(55,"_DA(1)_",""IV"",",PSIVACT=1 D IX^DIK K DA,DIK
- K ^PS(53.1,"ACX",PSJORD,PSJO)
- Q
- ;
- DONE ; Clean up
- K PSGPD,PSGPDN,PSGSCH,PSIVACT,PSJNOO
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJOEA 5881 printed Feb 18, 2025@23:34:33 Page 2
- PSJOEA ;BIR/MLM-INPATIENT ORDER ENTRY ;12 June 2019 09:31:53
- +1 ;;5.0;INPATIENT MEDICATIONS;**110,127,133,167,171,254,315,367,327**;16 DEC 97;Build 114
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ; Reference to ^PS(55 via DBIA #2191
- +4 ; Reference to EN^VALM via DBIA #10118
- +5 ; Reference to ^PSSLOCK via DBIA #2789
- +6 ; Reference to ^DPT via DBIA #10035
- +7 ; Reference to SDIMO^SDAMA203 via DBIA #4133
- +8 ;
- LOCK(DFN,PSJORD) ; Check if the order is locked
- +1 NEW Q
- SET Q=0
- +2 IF PSJORD=+PSJORD
- NEW PSJO
- SET PSJO=0
- FOR
- SET PSJO=$ORDER(^PS(53.1,"ACX",PSJORD,PSJO))
- if 'PSJO
- QUIT
- SET Q=$$LS^PSSLOCK(DFN,PSJO_"P")
- IF 'Q
- QUIT
- +3 IF Q
- QUIT 1
- +4 QUIT 0
- +5 ;
- SELECT ;
- +1 NEW PSJCLIN,O
- +2 if PSJORD=""!($GET(Y)<0)
- QUIT
- if ('$$LOCK^PSJOEA(PSGP,PSJORD))
- QUIT
- +3 NEW PSJO
- SET PSJO=0
- FOR
- SET PSJO=$ORDER(^PS(53.1,"ACX",PSJORD,PSJO))
- if 'PSJO
- QUIT
- Begin DoDot:1
- +4 SET PSGORD=""
- SET ON=PSJO_"P"
- +5 DO DISACTIO(PSGP,PSJO_"P",$GET(PSJPNV))
- if $GET(PSJO)["V"
- SET O=ON
- End DoDot:1
- +6 ; CLEAN UP VARIABLE FOR COMPLEX ORDER MESSAGE RJS*327
- KILL PSGCOMP,PSGFLG
- +7 IF $DATA(^TMP("PSJCOM",$JOB))
- DO CHK^PSJOEA1
- +8 if '$GET(PSGP)
- SET PSGP=$GET(DFN)
- +9 NEW PSJO
- SET PSJO=0
- FOR
- SET PSJO=$ORDER(^PS(53.1,"ACX",PSJORD,PSJO))
- if 'PSJO
- QUIT
- Begin DoDot:1
- +10 ; p367
- LOCK -^PS(53.1,PSJO)
- +11 ; Q:$G(Y)<0 p367 commented quit out
- DO UNL^PSSLOCK(PSGP,PSJO_"P")
- End DoDot:1
- +12 ; p367 Unlock complex orders (file 100) after verification of all child orders in the complex order.
- +13 NEW PSJO
- SET PSJO=0
- FOR
- SET PSJO=$ORDER(^TMP("PSJCVFY",$JOB,PSJO))
- if 'PSJO
- QUIT
- Begin DoDot:1
- +14 NEW PSJIDX
- SET PSJIDX=$GET(^TMP("PSJCVFY",$JOB,PSJO))
- +15 DO UNL^PSSLOCK(PSGP,PSJIDX)
- KILL ^TMP("PSJCVFY",$JOB,PSJO),PSJIDX
- End DoDot:1
- +16 DO DONE
- +17 QUIT
- +18 ;
- DISACTIO(DFN,PSJORD,PSJPNV) ; Display UD order and allow actions.
- +1 ; DFN - Patient IEN
- +2 ; PSJORD - Order #_location Code (P:53.1,V:55.01,U:55.06)
- +3 ; PSJPNV - Invoked from Pending/NV option; (gets different hidden menu)
- +4 NEW PSGP,PSJIVFLG,PSGSDX,PSGFDX,PSJXX1,ON55,PSJAPPT
- +5 if PSJORD'["P"
- QUIT
- +6 if $GET(PSJCLIN)=-2
- QUIT
- +7 SET PSGP=DFN
- DO ENIV^PSJAC
- +8 DO GETUD^PSJLMGUD(DFN,PSJORD)
- +9 SET PSGOEAV=$PIECE(PSJSYSP0,"^",9)&PSJSYSU
- +10 if $GET(PSJTUD)
- SET PSGPD=$GET(PSJCOI)
- SET PSGPDN=$$OINAME^PSJLMUTL(+PSGPD)
- +11 KILL PSGOENG
- IF '$DATA(PSGPRF)
- Begin DoDot:1
- +12 IF PSJORD["P"
- LOCK +^PS(53.1,+PSJORD):1
- IF '$TEST
- SET PSGOENG=1
- +13 IF $GET(PSGOENG)
- WRITE !,"This order is being edited by another terminal.",!
- SET PSGOENG=1
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- QUIT
- End DoDot:1
- if $GET(PSGOENG)
- QUIT
- +14 SET PSGACT=$$ENACTION^PSGOE1(PSGP,PSJORD)
- +15 ;L -^PS(53.1,+PSJORD) Q
- IF PSJORD["P"
- SET PSJXX1=$GET(^PS(53.1,+PSJORD,0))
- IF PSGP'=$PIECE(PSJXX1,U,15)!(DFN'=$PIECE(PSJXX1,U,15))
- QUIT
- +16 ;L -^PS(53.1,+PSJORD) Q
- IF PSJORD["P"
- Begin DoDot:1
- +17 IF $PIECE(PSJXX1,U,9)="N"
- IF ($PIECE(PSJXX1,U,4)'="U")
- Begin DoDot:2
- +18 SET P("PON")=PSJORD
- SET PSIVFLG=1
- +19 DO GT531^PSIVORFA(+PSGP,PSJORD)
- DO VF^PSIVORC2
- End DoDot:2
- QUIT
- +20 IF $PIECE(PSJXX1,U,9)="P"
- Begin DoDot:2
- +21 if $GET(PSJTUD)
- SET $PIECE(PSJXX1,U,4)="U"
- +22 NEW VAIP
- SET PSJCLIN=$GET(^PS(53.1,+PSJORD,"DSS"))
- SET PSJAPPT=$PIECE(PSJCLIN,"^",2)
- SET PSJCLIN=$PIECE(PSJCLIN,"^")
- +23 IF $PIECE(PSJXX1,U,4)="U"
- IF (+PSJPDD)
- Begin DoDot:3
- +24 IF $$PATCH^XPDUTL("SD*5.3*285")
- IF ($$SDIMO^SDAMA203(PSJCLIN,DFN)>-1)
- QUIT
- +25 WRITE !!,"Cannot process an Out-patient Unit Dose order for ",$PIECE($GET(^DPT(+PSGP,0)),U)
- DO PAUSE^VALM1
- SET PSJIVFLG=1
- SET PSJCLIN=-2
- End DoDot:3
- if (PSJCLIN=-2)
- QUIT
- +26 NEW PSGRSD,PSGRSDN,PSGRFD,PSGRFDN
- +27 DO REQDT^PSJLIVMD(PSJORD)
- +28 IF $PIECE(PSJXX1,U,4)="U"
- IF ($GET(PSGSCH)="")
- WRITE !!,"Invalid schedule, can't finish this order"
- DO PAUSE^VALM1
- QUIT
- +29 IF $PIECE(PSJXX1,U,4)="U"
- NEW PSJLM
- SET PSJLM=1
- SET PSGORD=PSJORD
- DO START^PSGOEF
- DO ENSFE^PSGOEE0(PSGP,PSGORD)
- DO @$SELECT($GET(PSJTUD):"FINISH^PSGOEF",1:"EN^VALM(""PSJ LM PENDING EDIT"")")
- Begin DoDot:3
- +30 KILL ^TMP("PSJINTER",$JOB),PSJOVR
- End DoDot:3
- QUIT
- +31 IF $PIECE(PSJXX1,U,4)'="U"
- IF PSGP=$PIECE(PSJXX1,U,15)
- IF DFN=$PIECE(PSJXX1,U,15)
- SET PSJLYN=PSJORD
- DO EN^PSJLIFN
- SET PSJIVFLG=1
- KILL PSJLYN,PSJMAI
- End DoDot:2
- QUIT
- End DoDot:1
- SET PSJXX1=$PIECE($GET(^PS(53.1,+PSJORD,0)),U,9)
- IF $SELECT($GET(PSJIVFLG):1,$GET(Y)<0:1,"PADE"[PSJXX1:1,1:0)
- QUIT
- +32 IF $GET(PSIVFLG)
- KILL PSIVFLG
- QUIT
- +33 SET PSGACT=$$ENACTION^PSGOE1(PSGP,PSJORD)
- SET PSGOEEF=0
- DO GETUD^PSJLMGUD(PSGP,PSJORD)
- DO ENSFE^PSGOEE0(PSGP,PSJORD)
- DO EN^VALM("PSJ LM UD ACTION")
- +34 ;Send SN to CPRS if autoverify OFF and Order Set Entry and no 21st piece
- +35 IF $DATA(PSGOES)
- IF 'PSGOEAV
- IF $DATA(PSGORD)
- IF PSGORD["P"
- IF $PIECE($GET(^PS(53.1,+PSGORD,0)),"^",21)']""
- DO ORSET^PSGOETO1
- +36 QUIT
- +37 ;
- ACTLOG(PSGORDP,DFN,PSGORD) ;Store 53.1 activity log in local array to be moved to 55
- +1 ;PSGORDP: IEN from 53.1
- +2 ;PSGORD : IEN from 55
- +3 NEW PSGX,PSGXDA,PSGAL531,Q,QQ
- +4 FOR PSGX=0:0
- SET PSGX=$ORDER(^PS(53.1,+PSGORDP,"A",PSGX))
- if 'PSGX
- QUIT
- Begin DoDot:1
- +5 SET PSGAL531=$GET(^PS(53.1,+PSGORDP,"A",PSGX,0))
- +6 SET QQ=$GET(^PS(55,DFN,5,+PSGORD,9,0))
- if QQ=""
- SET QQ="^55.09D"
- FOR Q=$PIECE(QQ,U,3)+1:1
- IF '$DATA(^(Q))
- SET $PIECE(QQ,U,3,4)=Q_U_Q
- SET ^(0)=QQ
- SET PSGXDA=Q
- QUIT
- +7 SET ^PS(55,DFN,5,+PSGORD,9,PSGXDA,0)=PSGAL531
- End DoDot:1
- +8 QUIT
- +9 ;
- UD ;
- +1 NEW DA,DR,DIE,PSJCMPDA
- DO ENGNA^PSGOETO
- SET $PIECE(^TMP("PSJCOM",$JOB,PSJO,0),"^",26)=DA_"U"
- SET $PIECE(^TMP("PSJCOM2",$JOB,PSJO,0),"^")=DA
- SET $PIECE(^(0),"^",18)=DA
- SET PSJCMPDA=DA
- +2 MERGE ^PS(55,PSGP,5,DA)=^TMP("PSJCOM2",$JOB,+PSJO)
- MERGE ^PS(53.1,+PSJO)=^TMP("PSJCOM",$JOB,+PSJO)
- DO EN1^PSJHL2(PSGP,"OD",+PSJO_"P")
- SET PSJNOO=$PIECE(^TMP("PSJCOM2",$JOB,+PSJO,.2),U,3)
- DO EN1^PSJHL2(PSGP,"SN",+PSJCMPDA_"U")
- +3 NEW PSGPDRG,PSGST,PSGNESD,PSGNEFD,ND2,ND2P1
- +4 SET PSGPDRG=$PIECE($GET(^PS(55,PSGP,5,PSJCMPDA,.2)),"^")
- SET PSGST=$PIECE($GET(^PS(55,PSGP,5,PSJCMPDA,0)),"^",7)
- +5 SET ND2=$GET(^PS(55,PSGP,5,PSJCMPDA,2))
- SET PSGNESD=$PIECE(ND2,"^",2)
- SET PSGNEFD=$PIECE(ND2,"^",4)
- DO CRA^PSGOETO
- +6 ;*315
- SET ND2P1=$GET(^PS(55,PSGP,5,PSJCMPDA,2))
- SET PSGRMVT=$PIECE(ND2P1,"^",2)
- +7 KILL ^PS(53.1,"ACX",PSJORD,PSJO)
- KILL PSJPREX
- +8 IF $GET(PSJCMPDA)
- DO CMPLX2^PSJCOM1(PSGP,PSJORD,+PSJCMPDA_"U")
- IF $GET(PSGPXN)
- SET PSJPREX=1
- +9 QUIT
- IV ;
- +1 KILL ON55
- IF $PIECE($GET(^PS(53.1,+PSJO,0)),"^",24)="R"
- IF $PIECE($GET(^PS(53.1,+PSJO,0)),"^",25)
- SET ON55=$PIECE(^PS(53.1,+PSJO,0),"^",25)
- +2 IF '$GET(ON55)
- DO NEW55^PSIVORFB
- +3 SET $PIECE(^TMP("PSJCOM",$JOB,PSJO,0),"^",26)=ON55
- SET $PIECE(^TMP("PSJCOM2",$JOB,PSJO,0),"^")=+ON55
- +4 SET $PIECE(^TMP("PSJCOM2",$JOB,PSJO,2),U,5)=PSJO_"P"
- SET $PIECE(^TMP("PSJCOM",$JOB,PSJO,0),U,26)=ON55
- +5 MERGE ^PS(55,DFN,"IV",+ON55)=^TMP("PSJCOM2",$JOB,+PSJO)
- MERGE ^PS(53.1,+PSJO)=^TMP("PSJCOM",$JOB,+PSJO)
- DO EN1^PSJHL2(PSGP,"OD",+PSJO_"P")
- SET P("NAT")=$PIECE(^TMP("PSJCOM2",$JOB,+PSJO,.2),U,5)
- DO EN1^PSJHL2(PSGP,"SN",ON55)
- +6 KILL DA,DIK
- SET DA(1)=DFN
- SET DA=+ON55
- SET DIK="^PS(55,"_DA(1)_",""IV"","
- SET PSIVACT=1
- DO IX^DIK
- KILL DA,DIK
- +7 KILL ^PS(53.1,"ACX",PSJORD,PSJO)
- +8 QUIT
- +9 ;
- DONE ; Clean up
- +1 KILL PSGPD,PSGPDN,PSGSCH,PSIVACT,PSJNOO
- +2 QUIT