- PSGOETO ;BIR/CML3-TRANSCRIBE ORDERS ;29-May-2012 14:30;PLS
- ;;5.0; INPATIENT MEDICATIONS ;**3,13,25,31,33,50,68,58,85,105,90,117,1005,110,111,112,161,1015**;16 DEC 97;Build 62
- ;
- ; Reference to ^PS(51.2 is supported by DBIA #2178.
- ; Reference to ^PS(55 is supported by DBIA #2191.
- ; Reference to ^PS(59.7 is supported by DBIA #2181.
- ; Reference to ^PSUHL is supported by DBIA 4803.
- ;
- ; Modified - IHS/MSC/PLS - 03/27/06 - Reapplied mod to line OUT+1,3 and CALLBOP
- ;
- W:'$D(PSGOEE)&'$D(PSGOES) !!,"...transcribing this ",$S($D(PSGOES):"",'PSGOEAV:"non-verified ",1:"active "),"order..." S PSGOETOF=1 S:PSGSM="" PSGSM=0
- I PSGPR'=PSGOEPR D:'$D(^PS(55,PSGP,0)) ENSET0^PSGNE3(PSGP) S $P(^PS(55,PSGP,5.1),U,2)=PSGPR,PSGOEPR=PSGPR
- K ND4,DA D ENGNN:'PSGOEAV,ENGNA:PSGOEAV S PSGDT=$$DATE^PSJUTL2() I $S($D(ORACTION):0,$G(PSGOEE)="R":1,+$G(^PS(55,PSGP,5.1))>PSGDT:0,1:$G(PSGOEE)'="E") D ENWALL^PSGNE3(PSGNESD,PSGNEFD,PSGP)
- I $D(^PS(51.2,+PSGMR,0)),$P(^(0),U,3)]"" S PSGMRN=$P(^(0),U,3)
- S ND=DA_U_PSGPR_U_PSGMR_"^U^"_PSGSM_U_PSGHSM_U_PSGST_"^^"_$S(PSGOEAV:"A",1:"N")_"^^^^^"_PSGDT_U_PSGP_U_PSGDT S:PSGNEDFD $P(ND,U,$P(PSGNEDFD,U)["L"+10)=+PSGNEDFD
- S:$D(PSGOEE) $P(ND,U,24,25)=PSGOEE_U_PSGOORD S:'PSGOEAV $P(ND,U,18)=DA S ND2=PSGSCH_U_$S(+PSGNESD=PSGNESD:+PSGNESD,1:"")_"^^"_+PSGNEFD_U_PSGS0Y_U_PSGS0XT_"^^^^"_+PSJPWD
- ; naked reference below refers to ^PS(55,PSGP,0)
- I PSGOEAV S F=^PS(55,PSGP,0) I $P(F,"^",7)="" S $P(F,"^",7)=$P($P(ND,"^",16),"."),$P(F,"^",8)="A",^(0)=F D LOGDFN^PSUHL(PSGP)
- S $P(ND4,U,7)=DUZ I PSGOEAV,PSJSYSU D
- .S $P(ND4,U,PSJSYSU,PSJSYSU+1)=DUZ_U_PSGDT,$P(ND4,U,+PSJSYSU=1+9)=1,$P(ND4,U,+PSJSYSU=3+9)=0
- .S $P(ND4,U,9,10)=+$P(ND4,U,9)_U_+$P(ND4,U,10)
- .I '$P(ND4,U,9) S ^PS(55,"APV",PSGP,DA)=""
- .I '$P(ND4,U,10) S ^PS(55,"NPV",PSGP,DA)=""
- .I $P(ND4,U,9) K ^PS(55,"APV",PSGP,DA)
- .I $P(ND4,U,10) K ^PS(55,"NPV",PSGP,DA)
- S F="^PS("_$S(PSGOEAV:"55,"_PSGP_",5",1:53.1)_","_DA_",",@(F_"0)")=ND
- ;naked reference below refers to full reference inside indirection @(F_".2)") for either file 53.1 or 55
- S @(F_".2)")=PSGPDRG_U_PSGDO_U_PSJNOO S:$G(PSJDOSE("DO"))]"" $P(^(.2),U,5,6)=$P(PSJDOSE("DO"),U,1,2)
- I '$D(PSJDOSE("DO")),$D(PSGORD),PSGPDRG=$P(@("^PS("_$S(PSGORD["U":"55,"_PSGP_",5",1:53.1)_","_+PSGORD_",.2)"),U) S $P(@(F_".2)"),U,5,6)=$P(@("^PS("_$S(PSGORD["U":"55,"_PSGP_",5",1:53.1)_","_+PSGORD_",.2)"),U,5,6)
- ;naked reference below refers to full reference inside indirection @(F_"2)") for either file 53.1 or 55
- S @(F_"2)")=$S(PSGOEAV:ND2,1:$P(ND2,"^",1,6)),^(4)=ND4 S:PSGSI]"" ^(6)=PSGSI
- S (C,X)=0 F S X=$O(^PS(53.45,PSJSYSP,2,X)) Q:'X S D=$G(^(X,0)) I D,$S('$P(D,U,3):1,1:$P(D,U,3)>DT) S C=C+1,@(F_"1,"_C_",0)")=$P(D,U,1,2),@(F_"1,""B"","_+D_","_C_")")=""
- S:C @(F_"1,0)")=U_$S(PSGOEAV:55.07,1:53.11)_"P^"_C_U_C
- S (C,Q)=0 F S Q=$O(^PS(53.45,PSJSYSP,1,Q)) Q:'Q S X=$G(^(Q,0)) S:X]"" C=C+1,@(F_"3,"_C_",0)")=X
- S:C @(F_"3,0)")=U_$S(PSGOEAV:55.08,1:53.12)_U_C_U_C
- I $P(ND,U,24)="R" S %X="^PS(55,"_PSGP_",5,"_+PSGORD_",12,",%Y=F_"12," D %XY^%RCR
- W "." D CRN:'PSGOEAV,CRA:PSGOEAV
- ; don't send message to CPRS if from Order Set and autoverify turned off
- S PSGORD=DA_$S(PSGOEAV:"U",1:"P")
- I $G(PSGOORD),$D(PSGOEE) N CLINAPPT S CLINAPPT=$S(PSGOORD["U":$G(^PS(55,PSGP,5,+PSGOORD,8)),PSGOORD["P":$G(^PS(53.1,+PSGOORD,"DSS")),1:"") I CLINAPPT D
- .N DIE,DA,DR
- .I PSGORD["U" S DIE="^PS(55,"_PSGP_",5,",DA=+PSGORD,DA(1)=PSGP,DR="130////"_+CLINAPPT_";" S:$P(CLINAPPT,"^",2) DR=DR_"131////"_$P(CLINAPPT,"^",2)_";"
- .I PSGORD["P" S DIE="^PS(53.1,",DA=+PSGORD,DR="113////"_+CLINAPPT_";" S:$P(CLINAPPT,"^",2) DR=DR_"126////"_$P(CLINAPPT,"^",2)_";"
- .I $G(DR) D ^DIE
- D:('$D(PSGOES))!(($D(PSGOES)&(PSGOEAV))) ORSET^PSGOETO1
- I $D(PSGOES),'$D(PSGOESON) N PSGOESON S PSGOESON=PSGORD D DISACTIO^PSJOE(DFN,PSGORD,0) D:PSGORD["U"&(PSGOESON=PSGORD)&($P(@(PSGOEEWF_"0)"),"^",9)'="D") EN^PSGPEN(PSGORD) G OUT
- D DONE S PSGCANFL="" I '$D(PSGOEE) S PSJLM=1,PSGOEEF=0 D GETUD^PSJLMGUD(PSGP,PSGORD),ENSFE^PSGOEE0(PSGP,PSGORD),EN^VALM("PSJ LM ACCEPT") I PSGCANFL=1 G OUT
- I $D(PSJSYSO) S PSGPOSA="W",PSGPOSD=PSGDT D ENPOS^PSGVDS
- S DA=+PSGORD,X=$P(PSGORD,DA,2) I PSJSYSL,$S(PSGOEAV:1,1:PSJSYSL<3),$S("AOU"[X:'$D(^PS(55,PSGP,5,+PSGORD,7)),1:'$D(^PS(53.1,+PSGORD,7))) D
- .; naked ref below is from line above, ^PS(53.1,+PSGORD,7)
- .S $P(^(7),U,1,2)=PSGDT_"^N"_$G(PSGOEE),PSGUOW=DUZ,PSGTOL=2,PSGTOO=$S("AOU"[X:1,1:2) D ENL^PSGVDS
- OUT ;
- K PSGOETOF
- D CALLBOP ;IHS/CIA/PLS - 10/14/05 - Call to Automated Dispensing System
- DONE ;
- I PSGOEAV L -^PS(55,PSGP,5,+PSGORD)
- I 'PSGOEAV L -^PS(53.1,+PSGORD)
- K C,D,ND,ND2,ND4,PSGDO,PSGDRG,PSGDRGN,PSGFOK,PSGHSM,PSGMR,PSGMRN,PSGNEDFD,PSGNEFD,PSGNESD,PSGPDRG,PSGPDRGN,PSGSI,PSGSTN,PSJDOSE
- Q
- ;
- ; Call Automated Dispensing System if present
- CALLBOP ;
- I $$PATCH^XPDUTL("BOP*1.0*1") D
- .D:$G(PSGOEAV) NEW^BOPCAP
- .D ^BOPSD
- Q
- CRA ;
- S:PSGPDRG ^PS(55,PSGP,5,"C",PSGPDRG,DA)="" S (^PS(55,"AUE",PSGP,DA),^PS(55,PSGP,5,"AU",PSGST,+PSGNEFD,DA),^PS(55,PSGP,5,"AUS",+PSGNEFD,DA))="",^PS(55,"AUD",+$P(ND2,"^",4),PSGP,DA)="",^PS(55,"AUDS",+$P(ND2,"^",2),PSGP,DA)=""
- I $$PATCH^XPDUTL("PXRM*1.5*12") S X(1)=+PSGNESD,X(2)=+PSGNEFD,DA(1)=PSGP D SPSPA^PSJXRFS(.X,.DA,"UD")
- S DA(1)=PSGP K DIK S DIK="^PS(55,"_DA(1)_",5,",DIK(1)=125 D EN1^DIK K DIK
- K PSGALO,PSGALR S DA(1)=PSGP,PSGAL("C")=PSJSYSU*10+$S('$D(PSGOEE):22500,PSGOEE="E":22600,1:22700) D ^PSGAL5 Q
- CRN ;
- S (^PS(53.1,"AC",PSGP,DA),^PS(53.1,"AS","N",PSGP,DA),^PS(53.1,"B",DA,DA),^PS(53.1,"C",PSGP,DA))="" S:PSGPDRG (^PS(53.1,"AOD",PSGP,PSGPDRG,DA),^PS(53.1,"D",PSGPDRG,DA))="" Q
- ENGNA ;
- F L +^PS(55,PSGP,5,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) S:'$D(^PS(55,PSGP,0)) ^(0)=PSGP,^PS(55,"B",PSGP,PSGP)="" S ND=$S($D(^PS(55,PSGP,5,0)):^(0),1:"^55.06IA") Q
- N PSGLCK S PSGLCK=0
- F DA=$P(ND,U,3)+1:1 W "." I '$D(^PS(55,PSGP,5,DA)),'$D(^PS(55,PSGP,5,"B",DA)) D I PSGLCK S ^PS(55,PSGP,5,DA,0)=DA,^PS(55,PSGP,5,"B",DA,DA)="",$P(ND,U,3)=DA,$P(ND,U,4)=$P(ND,U,4)+1,^PS(55,PSGP,5,0)=ND Q
- . L +^PS(55,PSGP,5,DA):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I S PSGLCK=1
- L -^PS(55,PSGP,5,0) Q
- ENGNN ;
- N ND F L +^PS(59.7,1,25):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I S DA=+$G(^PS(59.7,1,25)) Q
- F DA=DA+1:1 I '$D(^PS(53.1,DA)),'$D(^PS(53.1,"B",DA)) L +^PS(53.1,DA):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I S ^PS(59.7,1,25)=DA,^PS(53.1,DA,0)=DA,^PS(53.1,"B",DA,DA)="" Q
- F L +^PS(53.1,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I S ND=$G(^PS(53.1,0)),$P(ND,U,3)=DA,$P(ND,U,4)=$P(ND,U,4)+1,^(0)=ND Q
- L -^PS(59.7,1,25),-^PS(53.1,0)
- Q
- PSGOETO ;BIR/CML3-TRANSCRIBE ORDERS ;29-May-2012 14:30;PLS
- +1 ;;5.0; INPATIENT MEDICATIONS ;**3,13,25,31,33,50,68,58,85,105,90,117,1005,110,111,112,161,1015**;16 DEC 97;Build 62
- +2 ;
- +3 ; Reference to ^PS(51.2 is supported by DBIA #2178.
- +4 ; Reference to ^PS(55 is supported by DBIA #2191.
- +5 ; Reference to ^PS(59.7 is supported by DBIA #2181.
- +6 ; Reference to ^PSUHL is supported by DBIA 4803.
- +7 ;
- +8 ; Modified - IHS/MSC/PLS - 03/27/06 - Reapplied mod to line OUT+1,3 and CALLBOP
- +9 ;
- +10 IF '$DATA(PSGOEE)&'$DATA(PSGOES)
- WRITE !!,"...transcribing this ",$SELECT($DATA(PSGOES):"",'PSGOEAV:"non-verified ",1:"active "),"order..."
- SET PSGOETOF=1
- IF PSGSM=""
- SET PSGSM=0
- +11 IF PSGPR'=PSGOEPR
- IF '$DATA(^PS(55,PSGP,0))
- DO ENSET0^PSGNE3(PSGP)
- SET $PIECE(^PS(55,PSGP,5.1),U,2)=PSGPR
- SET PSGOEPR=PSGPR
- +12 KILL ND4,DA
- IF 'PSGOEAV
- DO ENGNN
- IF PSGOEAV
- DO ENGNA
- SET PSGDT=$$DATE^PSJUTL2()
- IF $SELECT($DATA(ORACTION):0,$GET(PSGOEE)="R":1,+$GET(^PS(55,PSGP,5.1))>PSGDT:0,1:$GET(PSGOEE)'="E")
- DO ENWALL^PSGNE3(PSGNESD,PSGNEFD,PSGP)
- +13 IF $DATA(^PS(51.2,+PSGMR,0))
- IF $PIECE(^(0),U,3)]""
- SET PSGMRN=$PIECE(^(0),U,3)
- +14 SET ND=DA_U_PSGPR_U_PSGMR_"^U^"_PSGSM_U_PSGHSM_U_PSGST_"^^"_$SELECT(PSGOEAV:"A",1:"N")_"^^^^^"_PSGDT_U_PSGP_U_PSGDT
- IF PSGNEDFD
- SET $PIECE(ND,U,$PIECE(PSGNEDFD,U)["L"+10)=+PSGNEDFD
- +15 IF $DATA(PSGOEE)
- SET $PIECE(ND,U,24,25)=PSGOEE_U_PSGOORD
- IF 'PSGOEAV
- SET $PIECE(ND,U,18)=DA
- SET ND2=PSGSCH_U_$SELECT(+PSGNESD=PSGNESD:+PSGNESD,1:"")_"^^"_+PSGNEFD_U_PSGS0Y_U_PSGS0XT_"^^^^"_+PSJPWD
- +16 ; naked reference below refers to ^PS(55,PSGP,0)
- +17 IF PSGOEAV
- SET F=^PS(55,PSGP,0)
- IF $PIECE(F,"^",7)=""
- SET $PIECE(F,"^",7)=$PIECE($PIECE(ND,"^",16),".")
- SET $PIECE(F,"^",8)="A"
- SET ^(0)=F
- DO LOGDFN^PSUHL(PSGP)
- +18 SET $PIECE(ND4,U,7)=DUZ
- IF PSGOEAV
- IF PSJSYSU
- Begin DoDot:1
- +19 SET $PIECE(ND4,U,PSJSYSU,PSJSYSU+1)=DUZ_U_PSGDT
- SET $PIECE(ND4,U,+PSJSYSU=1+9)=1
- SET $PIECE(ND4,U,+PSJSYSU=3+9)=0
- +20 SET $PIECE(ND4,U,9,10)=+$PIECE(ND4,U,9)_U_+$PIECE(ND4,U,10)
- +21 IF '$PIECE(ND4,U,9)
- SET ^PS(55,"APV",PSGP,DA)=""
- +22 IF '$PIECE(ND4,U,10)
- SET ^PS(55,"NPV",PSGP,DA)=""
- +23 IF $PIECE(ND4,U,9)
- KILL ^PS(55,"APV",PSGP,DA)
- +24 IF $PIECE(ND4,U,10)
- KILL ^PS(55,"NPV",PSGP,DA)
- End DoDot:1
- +25 SET F="^PS("_$SELECT(PSGOEAV:"55,"_PSGP_",5",1:53.1)_","_DA_","
- SET @(F_"0)")=ND
- +26 ;naked reference below refers to full reference inside indirection @(F_".2)") for either file 53.1 or 55
- +27 SET @(F_".2)")=PSGPDRG_U_PSGDO_U_PSJNOO
- IF $GET(PSJDOSE("DO"))]""
- SET $PIECE(^(.2),U,5,6)=$PIECE(PSJDOSE("DO"),U,1,2)
- +28 IF '$DATA(PSJDOSE("DO"))
- IF $DATA(PSGORD)
- IF PSGPDRG=$PIECE(@("^PS("_$SELECT(PSGORD["U":"55,"_PSGP_",5",1:53.1)_","_+PSGORD_",.2)"),U)
- SET $PIECE(@(F_".2)"),U,5,6)=$PIECE(@("^PS("_$SELECT(PSGORD["U":"55,"_PSGP_",5",1:53.1)_","_+PSGORD_",.2)"),U,5,6)
- +29 ;naked reference below refers to full reference inside indirection @(F_"2)") for either file 53.1 or 55
- +30 SET @(F_"2)")=$SELECT(PSGOEAV:ND2,1:$PIECE(ND2,"^",1,6))
- SET ^(4)=ND4
- IF PSGSI]""
- SET ^(6)=PSGSI
- +31 SET (C,X)=0
- FOR
- SET X=$ORDER(^PS(53.45,PSJSYSP,2,X))
- IF 'X
- QUIT
- SET D=$GET(^(X,0))
- IF D
- IF $SELECT('$PIECE(D,U,3):1,1:$PIECE(D,U,3)>DT)
- SET C=C+1
- SET @(F_"1,"_C_",0)")=$PIECE(D,U,1,2)
- SET @(F_"1,""B"","_+D_","_C_")")=""
- +32 IF C
- SET @(F_"1,0)")=U_$SELECT(PSGOEAV:55.07,1:53.11)_"P^"_C_U_C
- +33 SET (C,Q)=0
- FOR
- SET Q=$ORDER(^PS(53.45,PSJSYSP,1,Q))
- IF 'Q
- QUIT
- SET X=$GET(^(Q,0))
- IF X]""
- SET C=C+1
- SET @(F_"3,"_C_",0)")=X
- +34 IF C
- SET @(F_"3,0)")=U_$SELECT(PSGOEAV:55.08,1:53.12)_U_C_U_C
- +35 IF $PIECE(ND,U,24)="R"
- SET %X="^PS(55,"_PSGP_",5,"_+PSGORD_",12,"
- SET %Y=F_"12,"
- DO %XY^%RCR
- +36 WRITE "."
- IF 'PSGOEAV
- DO CRN
- IF PSGOEAV
- DO CRA
- +37 ; don't send message to CPRS if from Order Set and autoverify turned off
- +38 SET PSGORD=DA_$SELECT(PSGOEAV:"U",1:"P")
- +39 IF $GET(PSGOORD)
- IF $DATA(PSGOEE)
- NEW CLINAPPT
- SET CLINAPPT=$SELECT(PSGOORD["U":$GET(^PS(55,PSGP,5,+PSGOORD,8)),PSGOORD["P":$GET(^PS(53.1,+PSGOORD,"DSS")),1:"")
- IF CLINAPPT
- Begin DoDot:1
- +40 NEW DIE,DA,DR
- +41 IF PSGORD["U"
- SET DIE="^PS(55,"_PSGP_",5,"
- SET DA=+PSGORD
- SET DA(1)=PSGP
- SET DR="130////"_+CLINAPPT_";"
- IF $PIECE(CLINAPPT,"^",2)
- SET DR=DR_"131////"_$PIECE(CLINAPPT,"^",2)_";"
- +42 IF PSGORD["P"
- SET DIE="^PS(53.1,"
- SET DA=+PSGORD
- SET DR="113////"_+CLINAPPT_";"
- IF $PIECE(CLINAPPT,"^",2)
- SET DR=DR_"126////"_$PIECE(CLINAPPT,"^",2)_";"
- +43 IF $GET(DR)
- DO ^DIE
- End DoDot:1
- +44 IF ('$DATA(PSGOES))!(($DATA(PSGOES)&(PSGOEAV)))
- DO ORSET^PSGOETO1
- +45 IF $DATA(PSGOES)
- IF '$DATA(PSGOESON)
- NEW PSGOESON
- SET PSGOESON=PSGORD
- DO DISACTIO^PSJOE(DFN,PSGORD,0)
- IF PSGORD["U"&(PSGOESON=PSGORD)&($PIECE(@(PSGOEEWF_"0)"),"^",9)'="D")
- DO EN^PSGPEN(PSGORD)
- GOTO OUT
- +46 DO DONE
- SET PSGCANFL=""
- IF '$DATA(PSGOEE)
- SET PSJLM=1
- SET PSGOEEF=0
- DO GETUD^PSJLMGUD(PSGP,PSGORD)
- DO ENSFE^PSGOEE0(PSGP,PSGORD)
- DO EN^VALM("PSJ LM ACCEPT")
- IF PSGCANFL=1
- GOTO OUT
- +47 IF $DATA(PSJSYSO)
- SET PSGPOSA="W"
- SET PSGPOSD=PSGDT
- DO ENPOS^PSGVDS
- +48 SET DA=+PSGORD
- SET X=$PIECE(PSGORD,DA,2)
- IF PSJSYSL
- IF $SELECT(PSGOEAV:1,1:PSJSYSL<3)
- IF $SELECT("AOU"[X:'$DATA(^PS(55,PSGP,5,+PSGORD,7)),1:'$DATA(^PS(53.1,+PSGORD,7)))
- Begin DoDot:1
- +49 ; naked ref below is from line above, ^PS(53.1,+PSGORD,7)
- +50 SET $PIECE(^(7),U,1,2)=PSGDT_"^N"_$GET(PSGOEE)
- SET PSGUOW=DUZ
- SET PSGTOL=2
- SET PSGTOO=$SELECT("AOU"[X:1,1:2)
- DO ENL^PSGVDS
- End DoDot:1
- OUT ;
- +1 KILL PSGOETOF
- +2 ;IHS/CIA/PLS - 10/14/05 - Call to Automated Dispensing System
- DO CALLBOP
- DONE ;
- +1 IF PSGOEAV
- LOCK -^PS(55,PSGP,5,+PSGORD)
- +2 IF 'PSGOEAV
- LOCK -^PS(53.1,+PSGORD)
- +3 KILL C,D,ND,ND2,ND4,PSGDO,PSGDRG,PSGDRGN,PSGFOK,PSGHSM,PSGMR,PSGMRN,PSGNEDFD,PSGNEFD,PSGNESD,PSGPDRG,PSGPDRGN,PSGSI,PSGSTN,PSJDOSE
- +4 QUIT
- +5 ;
- +6 ; Call Automated Dispensing System if present
- CALLBOP ;
- +1 IF $$PATCH^XPDUTL("BOP*1.0*1")
- Begin DoDot:1
- +2 IF $GET(PSGOEAV)
- DO NEW^BOPCAP
- +3 DO ^BOPSD
- End DoDot:1
- +4 QUIT
- CRA ;
- +1 IF PSGPDRG
- SET ^PS(55,PSGP,5,"C",PSGPDRG,DA)=""
- SET (^PS(55,"AUE",PSGP,DA),^PS(55,PSGP,5,"AU",PSGST,+PSGNEFD,DA),^PS(55,PSGP,5,"AUS",+PSGNEFD,DA))=""
- SET ^PS(55,"AUD",+$PIECE(ND2,"^",4),PSGP,DA)=""
- SET ^PS(55,"AUDS",+$PIECE(ND2,"^",2),PSGP,DA)=""
- +2 IF $$PATCH^XPDUTL("PXRM*1.5*12")
- SET X(1)=+PSGNESD
- SET X(2)=+PSGNEFD
- SET DA(1)=PSGP
- DO SPSPA^PSJXRFS(.X,.DA,"UD")
- +3 SET DA(1)=PSGP
- KILL DIK
- SET DIK="^PS(55,"_DA(1)_",5,"
- SET DIK(1)=125
- DO EN1^DIK
- KILL DIK
- +4 KILL PSGALO,PSGALR
- SET DA(1)=PSGP
- SET PSGAL("C")=PSJSYSU*10+$SELECT('$DATA(PSGOEE):22500,PSGOEE="E":22600,1:22700)
- DO ^PSGAL5
- QUIT
- CRN ;
- +1 SET (^PS(53.1,"AC",PSGP,DA),^PS(53.1,"AS","N",PSGP,DA),^PS(53.1,"B",DA,DA),^PS(53.1,"C",PSGP,DA))=""
- IF PSGPDRG
- SET (^PS(53.1,"AOD",PSGP,PSGPDRG,DA),^PS(53.1,"D",PSGPDRG,DA))=""
- QUIT
- ENGNA ;
- +1 FOR
- LOCK +^PS(55,PSGP,5,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF '$DATA(^PS(55,PSGP,0))
- SET ^(0)=PSGP
- SET ^PS(55,"B",PSGP,PSGP)=""
- SET ND=$SELECT($DATA(^PS(55,PSGP,5,0)):^(0),1:"^55.06IA")
- QUIT
- +2 NEW PSGLCK
- SET PSGLCK=0
- +3 FOR DA=$PIECE(ND,U,3)+1:1
- WRITE "."
- IF '$DATA(^PS(55,PSGP,5,DA))
- IF '$DATA(^PS(55,PSGP,5,"B",DA))
- Begin DoDot:1
- +4 LOCK +^PS(55,PSGP,5,DA):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- SET PSGLCK=1
- End DoDot:1
- IF PSGLCK
- SET ^PS(55,PSGP,5,DA,0)=DA
- SET ^PS(55,PSGP,5,"B",DA,DA)=""
- SET $PIECE(ND,U,3)=DA
- SET $PIECE(ND,U,4)=$PIECE(ND,U,4)+1
- SET ^PS(55,PSGP,5,0)=ND
- QUIT
- +5 LOCK -^PS(55,PSGP,5,0)
- QUIT
- ENGNN ;
- +1 NEW ND
- FOR
- LOCK +^PS(59.7,1,25):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- SET DA=+$GET(^PS(59.7,1,25))
- QUIT
- +2 FOR DA=DA+1:1
- IF '$DATA(^PS(53.1,DA))
- IF '$DATA(^PS(53.1,"B",DA))
- LOCK +^PS(53.1,DA):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- SET ^PS(59.7,1,25)=DA
- SET ^PS(53.1,DA,0)=DA
- SET ^PS(53.1,"B",DA,DA)=""
- QUIT
- +3 FOR
- LOCK +^PS(53.1,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- SET ND=$GET(^PS(53.1,0))
- SET $PIECE(ND,U,3)=DA
- SET $PIECE(ND,U,4)=$PIECE(ND,U,4)+1
- SET ^(0)=ND
- QUIT
- +4 LOCK -^PS(59.7,1,25),-^PS(53.1,0)
- +5 QUIT
