PSGOE ;BIR/CML3-PROFILE AND ORDER ENTRY (MAIN DRIVER) ;24 Feb 99 / 10:40 AM
;;5.0;INPATIENT MEDICATIONS;**22,29,56,72,95,80,133,181,275,315**;16 DEC 97;Build 73
;;Per VHA Directive 2004-038, this routine should not be modified.
; Reference to ^PS(55 is supported by DBIA 2191
; Reference to ^PSSLOCK is supported by DBIA #2789
;
;N PSJNEW,PSGPTMP,PPAGE S PSJNEW=1
;
EN ;
N PSJLK,PSJPROT,XQORS,VALMEVL,PSJSYSO D ENCV^PSGSETU Q:$D(XQUIT)
S (PSGOL,PSGOP,PSGNEF,PSGOEAV,PSGPXN)="" I $P(PSJSYSU,";",2)&($P(PSJSYSU,";")'=3) S PSGION=ION D DDEV D ^%ZISC I DDEV="^" G DONE
K PSGVBY L +^PS(53.45,PSJSYSP):1 E D LOCKERR^PSJOE G DONE
F S (PSJLMCON,PSGPTMP)=0 D ENDPT^PSGP,HK Q:PSGP'>0 D I PSJLK D UL^PSSLOCK(PSGP)
.K ^TMP("PSJ",$J)
.S PSJLK=$$L^PSSLOCK(PSGP,1) I 'PSJLK W !,$C(7),$P(PSJLK,U,2) Q
.N NXTPT S NXTPT=0 ;NXTPT=1 indicates OE is complete for this patient
.K PSJLMPRO S PSJLMCON=0
.S PSJPROT=1,DFN=PSGP D EN^VALM("PSJ LM BRIEF PATIENT INFO")
.F Q:$G(NXTPT) D
..K PSGRDTX
..I $G(PSJLMCON)!$G(PSJNEWOE) D
...S PSJOL=$S(",S,L,"[(","_$G(PSJOL)_","):PSJOL,1:"S")
...S PSJLMPRO=1,PSJLMCON=1,PSJNEWOE=0 D EN^VALM("PSJU LM OE")
..I $G(PSJNEWOE)!($G(VALMBCK)="Q") S PSJNEWOE=0 Q
..I $G(PSJLMCON)&$G(PSJLMPRO)&'$D(^TMP("PSJ",$J)) D Q
...S PSJLMCON=0,PSJLMPRO=0 D EN^VALM("PSJ LM BRIEF PATIENT INFO")
...I $G(PSJNEWOE) S NXTPT=0 Q
...S NXTPT=1
..S NXTPT=1,PSJNEWOE=0 ; Go on to next patient
.I $G(PSGPXN),$P(PSJSYSW0,U,29)]"" S PSGPXPT=PSGP D K PSGPXPT S PSGPXN=0
..N DFN,PSGP S (PSGP,DFN)=PSGPXPT D ^PSGPER
.D ENCV^PSGSETU
K PSJLMPRO,^TMP("PSJPRO",$J),^TMP("PSJ",$J),^TMP("PSJON",$J)
;
DONE ;
I PSGOP,$P(PSJSYSL,"^",2)]"" D ENQL^PSGLW
I $D(PSJSYSO),PSGOP,$O(^PS(53.44,DUZ,1,PSGOP,1,0)) S PSGOEPOF="" D ^PSGOEPO
K PSJEXCPT,PSJOCER,^TMP($J,"PSJPRE")
K D0,DDEV,FQC,J,MRN,ND,ND2,PSGNEF,PSGNEFDO,PSGNESDO,PSGOE,PSGOEA,PSGOEAV,PSGOEDMR,PSGOENOF,PSGOEPOF,PSGOL,PSGOP,PSGPX,PSGTOL,PSGTOO,PSGUOW,PSJOPC,PSJORTOU,PSJORVP,PRI,PX,XX L -^PS(53.45,PSJSYSP)
K PSGOEORF,ORIFN,ORETURN,PSJORL,PSJORPCL,PSJORPV,PSJNOO,DDH,DDN,DRGI,FQ,HF,I1,ND1,NF,PDRG,PSGACTO,PSGAL,PSGCANFL,PSGDA,PSGPEN,PSGPENWS,PSGY,ND2P1 ;*315
G:$G(PSGPXN) ^PSGPER1 D ENKV^PSGSETU K ND1,PSG25,PSG26,PSGEB,PSBEBN,PSGNODE,PSGOAT,PSGSTAT,DDN,I2 Q
Q
;
HK ; Housekeeping (a nice COBOL term)
S PSGOENOF=0 I +PSJSYSU=1 D NOW^%DTC F Q=%:0 Q:PSGOENOF S Q=$O(^PS(55,PSGP,5,"AUS",Q)) Q:'Q F QQ=0:0 S QQ=$O(^PS(55,PSGP,5,"AUS",Q,QQ)) Q:'QQ I $D(^PS(55,PSGP,5,QQ,4)),$P(^(4),"^",10) S PSGOENOF=1 Q
I PSGOP,PSGOP'=PSGP D
.N PSJACPF,PSJACNWP,PSJPWD,PSJSYSL,PSJSYSW,PSJSYSW0,DFN,VAIN,VAERR S DFN=PSGOP
.D INP^VADPT S PSJPWD=+VAIN(4) I PSJPWD S PSJACPF=10 D WP^PSJAC D:$P(PSJSYSL,"^",2)]"" ENQL^PSGLW
I $D(PSJSYSO),PSGOP,PSGOP'=PSGP S PSGOEPOF="" D ^PSGOEPO
S:PSGP>0 PSJORVP=PSGP_";DPT(",PSJORL=$$ENORL^PSJUTL(PSJPWD),PSGOP=PSGP,X=""
Q
;
ORSU ; Oe/Rr Set-Up ;Not used anymore
Q
;
DDEV ;
F S POP=1 R !!,"Select Device to print ORDERS (10-1158): ",DDEV:DTIME W:'$T $C(7) S:'$T DDEV="^" Q:DDEV="^"!(DDEV=".") D:DDEV?1."?" DDH K %ZIS,IO("Q") S %ZIS="NQ",IOP=DDEV D ^%ZIS Q:'POP
S:DDEV="^" %=-1 Q:POP I $E(IOST)'="P"!(PSGION=ION) W $C(7),!!?2,"The device you have selected is not a printer. You must select a printer." W:PSGION=ION !,"You cannot print the orders to your terminal." G DDEV
S PSJSYSO=ION_"^"_IO W:$S(DDEV=" ":1,$L(DDEV)'<$L(ION):0,1:DDEV=$E(ION,1,$L(DDEV))) $S(DDEV=" ":" "_ION,1:$E(ION,$L(DDEV)+1,$L(ION)))
F Q=0:0 S Q=$O(^PS(53.44,DUZ,1,Q)) Q:'Q I $O(^(Q,1,0)) Q
Q:'Q W !!?2,"You have unprinted orders. If you do not print them now, you will not be",!,"able to print them from here later."
F W !!,"Do you want to print them now" S %=1 D YN^DICN Q:% W !!?2,"Enter 'YES' to print the orders now. If you enter 'NO', you will not be",!,"able to print them from here later. (Enter '^' to exit this option.)"
Q:%<0 I %=1 S PSGOEPOF="A" D ^PSGOEPO S %=0 Q
S DA=DUZ,DIK="^PS(53.44," D ^DIK S %=0 Q
;
DDH ;
W !!?2,"Select a device to print each patient's orders (VA Form 10-1158) after you",!,"have entered them. If you do not select a device, no orders will print." Q
;
CHUCK ; This appears to be an ancient test tag - not called from any file or other routine.
D ENCV^PSGSETU Q:$D(XQUIT) R !!,"PSJSYSU: ",PSJSYSU:DTIME S:'$T PSJSYSU="^" I "^"'[PSJSYSU G EN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOE 4349 printed Sep 23, 2025@19:37:53 Page 2
PSGOE ;BIR/CML3-PROFILE AND ORDER ENTRY (MAIN DRIVER) ;24 Feb 99 / 10:40 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**22,29,56,72,95,80,133,181,275,315**;16 DEC 97;Build 73
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Reference to ^PS(55 is supported by DBIA 2191
+4 ; Reference to ^PSSLOCK is supported by DBIA #2789
+5 ;
+6 ;N PSJNEW,PSGPTMP,PPAGE S PSJNEW=1
+7 ;
EN ;
+1 NEW PSJLK,PSJPROT,XQORS,VALMEVL,PSJSYSO
DO ENCV^PSGSETU
if $DATA(XQUIT)
QUIT
+2 SET (PSGOL,PSGOP,PSGNEF,PSGOEAV,PSGPXN)=""
IF $PIECE(PSJSYSU,";",2)&($PIECE(PSJSYSU,";")'=3)
SET PSGION=ION
DO DDEV
DO ^%ZISC
IF DDEV="^"
GOTO DONE
+3 KILL PSGVBY
LOCK +^PS(53.45,PSJSYSP):1
IF '$TEST
DO LOCKERR^PSJOE
GOTO DONE
+4 FOR
SET (PSJLMCON,PSGPTMP)=0
DO ENDPT^PSGP
DO HK
if PSGP'>0
QUIT
Begin DoDot:1
+5 KILL ^TMP("PSJ",$JOB)
+6 SET PSJLK=$$L^PSSLOCK(PSGP,1)
IF 'PSJLK
WRITE !,$CHAR(7),$PIECE(PSJLK,U,2)
QUIT
+7 ;NXTPT=1 indicates OE is complete for this patient
NEW NXTPT
SET NXTPT=0
+8 KILL PSJLMPRO
SET PSJLMCON=0
+9 SET PSJPROT=1
SET DFN=PSGP
DO EN^VALM("PSJ LM BRIEF PATIENT INFO")
+10 FOR
if $GET(NXTPT)
QUIT
Begin DoDot:2
+11 KILL PSGRDTX
+12 IF $GET(PSJLMCON)!$GET(PSJNEWOE)
Begin DoDot:3
+13 SET PSJOL=$SELECT(",S,L,"[(","_$GET(PSJOL)_","):PSJOL,1:"S")
+14 SET PSJLMPRO=1
SET PSJLMCON=1
SET PSJNEWOE=0
DO EN^VALM("PSJU LM OE")
End DoDot:3
+15 IF $GET(PSJNEWOE)!($GET(VALMBCK)="Q")
SET PSJNEWOE=0
QUIT
+16 IF $GET(PSJLMCON)&$GET(PSJLMPRO)&'$DATA(^TMP("PSJ",$JOB))
Begin DoDot:3
+17 SET PSJLMCON=0
SET PSJLMPRO=0
DO EN^VALM("PSJ LM BRIEF PATIENT INFO")
+18 IF $GET(PSJNEWOE)
SET NXTPT=0
QUIT
+19 SET NXTPT=1
End DoDot:3
QUIT
+20 ; Go on to next patient
SET NXTPT=1
SET PSJNEWOE=0
End DoDot:2
+21 IF $GET(PSGPXN)
IF $PIECE(PSJSYSW0,U,29)]""
SET PSGPXPT=PSGP
Begin DoDot:2
+22 NEW DFN,PSGP
SET (PSGP,DFN)=PSGPXPT
DO ^PSGPER
End DoDot:2
KILL PSGPXPT
SET PSGPXN=0
+23 DO ENCV^PSGSETU
End DoDot:1
IF PSJLK
DO UL^PSSLOCK(PSGP)
+24 KILL PSJLMPRO,^TMP("PSJPRO",$JOB),^TMP("PSJ",$JOB),^TMP("PSJON",$JOB)
+25 ;
DONE ;
+1 IF PSGOP
IF $PIECE(PSJSYSL,"^",2)]""
DO ENQL^PSGLW
+2 IF $DATA(PSJSYSO)
IF PSGOP
IF $ORDER(^PS(53.44,DUZ,1,PSGOP,1,0))
SET PSGOEPOF=""
DO ^PSGOEPO
+3 KILL PSJEXCPT,PSJOCER,^TMP($JOB,"PSJPRE")
+4 KILL D0,DDEV,FQC,J,MRN,ND,ND2,PSGNEF,PSGNEFDO,PSGNESDO,PSGOE,PSGOEA,PSGOEAV,PSGOEDMR,PSGOENOF,PSGOEPOF,PSGOL,PSGOP,PSGPX,PSGTOL,PSGTOO,PSGUOW,PSJOPC,PSJORTOU,PSJORVP,PRI,PX,XX
LOCK -^PS(53.45,PSJSYSP)
+5 ;*315
KILL PSGOEORF,ORIFN,ORETURN,PSJORL,PSJORPCL,PSJORPV,PSJNOO,DDH,DDN,DRGI,FQ,HF,I1,ND1,NF,PDRG,PSGACTO,PSGAL,PSGCANFL,PSGDA,PSGPEN,PSGPENWS,PSGY,ND2P1
+6 if $GET(PSGPXN)
GOTO ^PSGPER1
DO ENKV^PSGSETU
KILL ND1,PSG25,PSG26,PSGEB,PSBEBN,PSGNODE,PSGOAT,PSGSTAT,DDN,I2
QUIT
+7 QUIT
+8 ;
HK ; Housekeeping (a nice COBOL term)
+1 SET PSGOENOF=0
IF +PSJSYSU=1
DO NOW^%DTC
FOR Q=%:0
if PSGOENOF
QUIT
SET Q=$ORDER(^PS(55,PSGP,5,"AUS",Q))
if 'Q
QUIT
FOR QQ=0:0
SET QQ=$ORDER(^PS(55,PSGP,5,"AUS",Q,QQ))
if 'QQ
QUIT
IF $DATA(^PS(55,PSGP,5,QQ,4))
IF $PIECE(^(4),"^",10)
SET PSGOENOF=1
QUIT
+2 IF PSGOP
IF PSGOP'=PSGP
Begin DoDot:1
+3 NEW PSJACPF,PSJACNWP,PSJPWD,PSJSYSL,PSJSYSW,PSJSYSW0,DFN,VAIN,VAERR
SET DFN=PSGOP
+4 DO INP^VADPT
SET PSJPWD=+VAIN(4)
IF PSJPWD
SET PSJACPF=10
DO WP^PSJAC
if $PIECE(PSJSYSL,"^",2)]""
DO ENQL^PSGLW
End DoDot:1
+5 IF $DATA(PSJSYSO)
IF PSGOP
IF PSGOP'=PSGP
SET PSGOEPOF=""
DO ^PSGOEPO
+6 if PSGP>0
SET PSJORVP=PSGP_";DPT("
SET PSJORL=$$ENORL^PSJUTL(PSJPWD)
SET PSGOP=PSGP
SET X=""
+7 QUIT
+8 ;
ORSU ; Oe/Rr Set-Up ;Not used anymore
+1 QUIT
+2 ;
DDEV ;
+1 FOR
SET POP=1
READ !!,"Select Device to print ORDERS (10-1158): ",DDEV:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET DDEV="^"
if DDEV="^"!(DDEV=".")
QUIT
if DDEV?1."?"
DO DDH
KILL %ZIS,IO("Q")
SET %ZIS="NQ"
SET IOP=DDEV
DO ^%ZIS
if 'POP
QUIT
+2 if DDEV="^"
SET %=-1
if POP
QUIT
IF $EXTRACT(IOST)'="P"!(PSGION=ION)
WRITE $CHAR(7),!!?2,"The device you have selected is not a printer. You must select a printer."
if PSGION=ION
WRITE !,"You cannot print the orders to your terminal."
GOTO DDEV
+3 SET PSJSYSO=ION_"^"_IO
if $SELECT(DDEV=" "
WRITE $SELECT(DDEV=" ":" "_ION,1:$EXTRACT(ION,$LENGTH(DDEV)+1,$LENGTH(ION)))
+4 FOR Q=0:0
SET Q=$ORDER(^PS(53.44,DUZ,1,Q))
if 'Q
QUIT
IF $ORDER(^(Q,1,0))
QUIT
+5 if 'Q
QUIT
WRITE !!?2,"You have unprinted orders. If you do not print them now, you will not be",!,"able to print them from here later."
+6 FOR
WRITE !!,"Do you want to print them now"
SET %=1
DO YN^DICN
if %
QUIT
WRITE !!?2,"Enter 'YES' to print the orders now. If you enter 'NO', you will not be",!,"able to print them from here later. (Enter '^' to exit this option.)"
+7 if %<0
QUIT
IF %=1
SET PSGOEPOF="A"
DO ^PSGOEPO
SET %=0
QUIT
+8 SET DA=DUZ
SET DIK="^PS(53.44,"
DO ^DIK
SET %=0
QUIT
+9 ;
DDH ;
+1 WRITE !!?2,"Select a device to print each patient's orders (VA Form 10-1158) after you",!,"have entered them. If you do not select a device, no orders will print."
QUIT
+2 ;
CHUCK ; This appears to be an ancient test tag - not called from any file or other routine.
+1 DO ENCV^PSGSETU
if $DATA(XQUIT)
QUIT
READ !!,"PSJSYSU: ",PSJSYSU:DTIME
if '$TEST
SET PSJSYSU="^"
IF "^"'[PSJSYSU
GOTO EN
+2 QUIT
