PSOLMUTL ;BIR/SAB - listman utilities ;Dec 08, 2021@10:34
;;7.0;OUTPATIENT PHARMACY;**19,46,84,99,131,132,148,268,225,305,386,390,622,441**;DEC 1997;Build 208
;External reference FULL^VALM1 supported by dbia 10116
;External reference $$SETSTR^VALM1 supported by dbia 10116
;External reference EN2^GMRAPEMO supported by dbia 190
;External reference to ^ORD(101 supported by DBIA 872
;External reference to RE^VALM4 supported by dbia 10120
;
EN W @IOF S VALMCNT=0
D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) W $C(7),!!?5,"Site parameter must be defined!",! G INITQ
D EN^PSOLMPI
INITQ Q
HDR ;patient med profile display
K VALMHDR S HDR=^TMP("PSOHDR",$J,1,0),X=""
I ^TMP("PSOHDR",$J,8,0) S X="<A>"
E S PSONOAL="" D ALLERGY^PSOORUT2 S:PSONOAL'="" X="<NO ALLERGY ASSESSMENT>" K PSONOAL
I $G(^TMP("PSOHDR",$J,14,0))'="" S X=X_"<"_^TMP("PSOHDR",$J,14,0)_">"
I X'="" S X=IORVON_X_IORVOFF,HDR=$$SETSTR^VALM1(X,HDR,80-$L(X),80)
S VALMHDR(1)=HDR
S HDR=" PID: "_^TMP("PSOHDR",$J,2,0)
S VALMHDR(2)=$$SETSTR^VALM1("Ht(cm): "_^TMP("PSOHDR",$J,7,0),HDR,52,27)
S HDR=" DOB: "_^TMP("PSOHDR",$J,3,0)_" ("_^TMP("PSOHDR",$J,4,0)_")"
S VALMHDR(3)=$$SETSTR^VALM1(" Wt(kg): "_^TMP("PSOHDR",$J,6,0),HDR,51,28)
S HDR=" SEX: "_$E(^TMP("PSOHDR",$J,5,0),1,44)
S VALMHDR(4)=HDR
S $P(VALMHDR(4)," ",30)=" "_$E(^TMP("PSOHDR",$J,5,0),48,80)
Q:$G(PS)="VIEW"!($G(PS)="DELETE")
K HDR S HDR=$G(^TMP("PSOHDR",$J,13,0))
I $G(HDR)]"" D Q
.S VALMHDR(5)=$$SETSTR^VALM1(" BSA (m2): "_^TMP("PSOHDR",$J,12,0),HDR,49,19)
.S VALMHDR(6)=$G(^TMP("PSOHDR",$J,9,0))
.S VALMHDR(7)=$G(^TMP("PSOHDR",$J,10,0))
.S VALMHDR(8)=$G(^TMP("PSOHDR",$J,11,0))
S VALMHDR(5)=$G(^TMP("PSOHDR",$J,9,0))
S VALMHDR(6)=$G(^TMP("PSOHDR",$J,10,0))
Q
;
NEWALL(DFN) ; Enter Allergy info.
N PSOID D FULL^VALM1,EN2^GMRAPEM0,^PSOORUT2 S VALMBCK="R"
Q
NEWSEL ;allows order selection by number instead of action
S Y=$P(XQORNOD(0),"=",2) N VALMCNT D NEWSEL^PSOORNE2
Q
EDTSEL ;allows edit selection by number instead of action - active orders
N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOOREDT
Q
SELAL ;selection of allergy by number instead of action - select allergy
N VALMCNT S Y=$P(XQORNOD(0),"=",2) D SELAL^PSOORDA
Q
EDTNEW ;allows edit selection by number instead of action - new orders
N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOORNE1
Q
EDTRNEW ;allows edit selection by number instead of action - renew orders
N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOORNE4
Q
EDTPEN ;allows edit selection by number instead of action - pending orders
N VALMCNT S Y=$P(XQORNOD(0),"=",2),SEDT=1 G EDTSEL^PSOORNEW
Q
HLDHDR ;keeps patient's header info
S IOTM=VALM("TM"),IOBM=IOSL W IOSC W @IOSTBM W IORC
Q
;
BYPASS S:$G(PSOFDR) SIGOK=1 S Y=-1,VALMBCK="Q"
Q
ACTIONS() ;screen actions on active orders
Q:$G(PKI1)=2 0
N DIC,X,Y K DIC,Y S DIC="^ORD(101,"_DA(1)_",10,",X=DA,DIC(0)="ZN" D ^DIC Q:Y<0 0
S Y=Y(0,0)
I Y="PSO REFILL" Q $S(PSOACT["R":1,1:0)
I Y="PSO RENEW" Q $S(PSOACT["N":1,1:0)
I Y="PSO REPRINT" Q $S(PSOACT["P":1,1:0)
I Y="PSO EDIT ORDERS" Q $S(PSOACT["E":1,1:0)
I Y="PSO RELEASE" Q $S(PSOACT["L":1,1:0)
I Y="PSO PARTIAL" Q $S(PSOACT["T":1,1:0)
I Y="PSO CANCEL" Q $S(PSOACT["D":1,1:0)
I Y="PSO HOLD" Q $S(PSOACT["H":1,1:0)
I Y="PSO UNHOLD" Q $S(PSOACT["U":1,1:0)
I Y="PSO PARK" Q $S($E(PSOACT,1,2)="PK":1,1:0) ;441 PAPI
I Y="PSO UNPARK" Q $S(PSOACT["UPK":1,1:0)
I Y="PSO LM BACKDOOR COPY" Q $S(PSOACT["C":1,1:0)
I Y="PSO VERIFY" Q $S(PSOACT["V":1,1:0)
I Y="PSO ACTIVITY LOGS" Q 1
Q 1
ACTIONS1() ;screen actions on pending orders
Q:$G(PKI1)=2 0
N DIC,X,Y K DIC,Y S DIC="^ORD(101,"_DA(1)_",10,",X=DA,DIC(0)="ZN" D ^DIC Q:Y<0 0
S Y=Y(0,0)
I Y="PSO LM DISCONTINUE" Q $S(PSOACT["D":1,1:0)
I Y="PSO LM EDIT" Q $S(PSOACT["E":1,1:0)
I Y="PSO LM FINISH" Q $S(PSOACT["F":1,1:0)
I Y="PSO LM FLAG" Q $S(PSOACT["X":1,1:0)
Q 1
PKIACT() ;screen actions on pending orders DEA/PKI proj.
Q:$G(PKI1)=2 0
N DIC,X,Y K DIC,Y S DIC="^ORD(101,"_DA(1)_",10,",X=DA,DIC(0)="ZN" D ^DIC Q:Y<0 0
S Y=Y(0,0)
I Y="PSO LM DISCONTINUE" Q $S(PSOACT["D":1,1:0)
I Y="PSO LM RENEW EDIT" Q $S(PSOACT["E":1,1:0)
I Y="PSO LM FLAG",'$G(PSOFDR) Q 0
I Y="PSO LM FLAG",$G(PSOFDR) Q $S(PSOACT["X":1,1:0)
Q 1
RFDSP ;screen action to toggle display of prescriptions between LAST FILL date and LAST RELEASE Date.
S PSORFG='$G(PSORFG)
I '$D(PSOSD) D ^PSOBUILD
D ^PSOORUT2,BLD^PSOORUT1
K VALMHDR
D RE^VALM4
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOLMUTL 4484 printed Apr 09, 2024@21:30:20 Page 2
PSOLMUTL ;BIR/SAB - listman utilities ;Dec 08, 2021@10:34
+1 ;;7.0;OUTPATIENT PHARMACY;**19,46,84,99,131,132,148,268,225,305,386,390,622,441**;DEC 1997;Build 208
+2 ;External reference FULL^VALM1 supported by dbia 10116
+3 ;External reference $$SETSTR^VALM1 supported by dbia 10116
+4 ;External reference EN2^GMRAPEMO supported by dbia 190
+5 ;External reference to ^ORD(101 supported by DBIA 872
+6 ;External reference to RE^VALM4 supported by dbia 10120
+7 ;
EN WRITE @IOF
SET VALMCNT=0
+1 if '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
WRITE $CHAR(7),!!?5,"Site parameter must be defined!",!
GOTO INITQ
+2 DO EN^PSOLMPI
INITQ QUIT
HDR ;patient med profile display
+1 KILL VALMHDR
SET HDR=^TMP("PSOHDR",$JOB,1,0)
SET X=""
+2 IF ^TMP("PSOHDR",$JOB,8,0)
SET X="<A>"
+3 IF '$TEST
SET PSONOAL=""
DO ALLERGY^PSOORUT2
if PSONOAL'=""
SET X="<NO ALLERGY ASSESSMENT>"
KILL PSONOAL
+4 IF $GET(^TMP("PSOHDR",$JOB,14,0))'=""
SET X=X_"<"_^TMP("PSOHDR",$JOB,14,0)_">"
+5 IF X'=""
SET X=IORVON_X_IORVOFF
SET HDR=$$SETSTR^VALM1(X,HDR,80-$LENGTH(X),80)
+6 SET VALMHDR(1)=HDR
+7 SET HDR=" PID: "_^TMP("PSOHDR",$JOB,2,0)
+8 SET VALMHDR(2)=$$SETSTR^VALM1("Ht(cm): "_^TMP("PSOHDR",$JOB,7,0),HDR,52,27)
+9 SET HDR=" DOB: "_^TMP("PSOHDR",$JOB,3,0)_" ("_^TMP("PSOHDR",$JOB,4,0)_")"
+10 SET VALMHDR(3)=$$SETSTR^VALM1(" Wt(kg): "_^TMP("PSOHDR",$JOB,6,0),HDR,51,28)
+11 SET HDR=" SEX: "_$EXTRACT(^TMP("PSOHDR",$JOB,5,0),1,44)
+12 SET VALMHDR(4)=HDR
+13 SET $PIECE(VALMHDR(4)," ",30)=" "_$EXTRACT(^TMP("PSOHDR",$JOB,5,0),48,80)
+14 if $GET(PS)="VIEW"!($GET(PS)="DELETE")
QUIT
+15 KILL HDR
SET HDR=$GET(^TMP("PSOHDR",$JOB,13,0))
+16 IF $GET(HDR)]""
Begin DoDot:1
+17 SET VALMHDR(5)=$$SETSTR^VALM1(" BSA (m2): "_^TMP("PSOHDR",$JOB,12,0),HDR,49,19)
+18 SET VALMHDR(6)=$GET(^TMP("PSOHDR",$JOB,9,0))
+19 SET VALMHDR(7)=$GET(^TMP("PSOHDR",$JOB,10,0))
+20 SET VALMHDR(8)=$GET(^TMP("PSOHDR",$JOB,11,0))
End DoDot:1
QUIT
+21 SET VALMHDR(5)=$GET(^TMP("PSOHDR",$JOB,9,0))
+22 SET VALMHDR(6)=$GET(^TMP("PSOHDR",$JOB,10,0))
+23 QUIT
+24 ;
NEWALL(DFN) ; Enter Allergy info.
+1 NEW PSOID
DO FULL^VALM1
DO EN2^GMRAPEM0
DO ^PSOORUT2
SET VALMBCK="R"
+2 QUIT
NEWSEL ;allows order selection by number instead of action
+1 SET Y=$PIECE(XQORNOD(0),"=",2)
NEW VALMCNT
DO NEWSEL^PSOORNE2
+2 QUIT
EDTSEL ;allows edit selection by number instead of action - active orders
+1 NEW VALMCNT
SET Y=$PIECE(XQORNOD(0),"=",2)
DO EDTSEL^PSOOREDT
+2 QUIT
SELAL ;selection of allergy by number instead of action - select allergy
+1 NEW VALMCNT
SET Y=$PIECE(XQORNOD(0),"=",2)
DO SELAL^PSOORDA
+2 QUIT
EDTNEW ;allows edit selection by number instead of action - new orders
+1 NEW VALMCNT
SET Y=$PIECE(XQORNOD(0),"=",2)
DO EDTSEL^PSOORNE1
+2 QUIT
EDTRNEW ;allows edit selection by number instead of action - renew orders
+1 NEW VALMCNT
SET Y=$PIECE(XQORNOD(0),"=",2)
DO EDTSEL^PSOORNE4
+2 QUIT
EDTPEN ;allows edit selection by number instead of action - pending orders
+1 NEW VALMCNT
SET Y=$PIECE(XQORNOD(0),"=",2)
SET SEDT=1
GOTO EDTSEL^PSOORNEW
+2 QUIT
HLDHDR ;keeps patient's header info
+1 SET IOTM=VALM("TM")
SET IOBM=IOSL
WRITE IOSC
WRITE @IOSTBM
WRITE IORC
+2 QUIT
+3 ;
BYPASS if $GET(PSOFDR)
SET SIGOK=1
SET Y=-1
SET VALMBCK="Q"
+1 QUIT
ACTIONS() ;screen actions on active orders
+1 if $GET(PKI1)=2
QUIT 0
+2 NEW DIC,X,Y
KILL DIC,Y
SET DIC="^ORD(101,"_DA(1)_",10,"
SET X=DA
SET DIC(0)="ZN"
DO ^DIC
if Y<0
QUIT 0
+3 SET Y=Y(0,0)
+4 IF Y="PSO REFILL"
QUIT $SELECT(PSOACT["R":1,1:0)
+5 IF Y="PSO RENEW"
QUIT $SELECT(PSOACT["N":1,1:0)
+6 IF Y="PSO REPRINT"
QUIT $SELECT(PSOACT["P":1,1:0)
+7 IF Y="PSO EDIT ORDERS"
QUIT $SELECT(PSOACT["E":1,1:0)
+8 IF Y="PSO RELEASE"
QUIT $SELECT(PSOACT["L":1,1:0)
+9 IF Y="PSO PARTIAL"
QUIT $SELECT(PSOACT["T":1,1:0)
+10 IF Y="PSO CANCEL"
QUIT $SELECT(PSOACT["D":1,1:0)
+11 IF Y="PSO HOLD"
QUIT $SELECT(PSOACT["H":1,1:0)
+12 IF Y="PSO UNHOLD"
QUIT $SELECT(PSOACT["U":1,1:0)
+13 ;441 PAPI
IF Y="PSO PARK"
QUIT $SELECT($EXTRACT(PSOACT,1,2)="PK":1,1:0)
+14 IF Y="PSO UNPARK"
QUIT $SELECT(PSOACT["UPK":1,1:0)
+15 IF Y="PSO LM BACKDOOR COPY"
QUIT $SELECT(PSOACT["C":1,1:0)
+16 IF Y="PSO VERIFY"
QUIT $SELECT(PSOACT["V":1,1:0)
+17 IF Y="PSO ACTIVITY LOGS"
QUIT 1
+18 QUIT 1
ACTIONS1() ;screen actions on pending orders
+1 if $GET(PKI1)=2
QUIT 0
+2 NEW DIC,X,Y
KILL DIC,Y
SET DIC="^ORD(101,"_DA(1)_",10,"
SET X=DA
SET DIC(0)="ZN"
DO ^DIC
if Y<0
QUIT 0
+3 SET Y=Y(0,0)
+4 IF Y="PSO LM DISCONTINUE"
QUIT $SELECT(PSOACT["D":1,1:0)
+5 IF Y="PSO LM EDIT"
QUIT $SELECT(PSOACT["E":1,1:0)
+6 IF Y="PSO LM FINISH"
QUIT $SELECT(PSOACT["F":1,1:0)
+7 IF Y="PSO LM FLAG"
QUIT $SELECT(PSOACT["X":1,1:0)
+8 QUIT 1
PKIACT() ;screen actions on pending orders DEA/PKI proj.
+1 if $GET(PKI1)=2
QUIT 0
+2 NEW DIC,X,Y
KILL DIC,Y
SET DIC="^ORD(101,"_DA(1)_",10,"
SET X=DA
SET DIC(0)="ZN"
DO ^DIC
if Y<0
QUIT 0
+3 SET Y=Y(0,0)
+4 IF Y="PSO LM DISCONTINUE"
QUIT $SELECT(PSOACT["D":1,1:0)
+5 IF Y="PSO LM RENEW EDIT"
QUIT $SELECT(PSOACT["E":1,1:0)
+6 IF Y="PSO LM FLAG"
IF '$GET(PSOFDR)
QUIT 0
+7 IF Y="PSO LM FLAG"
IF $GET(PSOFDR)
QUIT $SELECT(PSOACT["X":1,1:0)
+8 QUIT 1
RFDSP ;screen action to toggle display of prescriptions between LAST FILL date and LAST RELEASE Date.
+1 SET PSORFG='$GET(PSORFG)
+2 IF '$DATA(PSOSD)
DO ^PSOBUILD
+3 DO ^PSOORUT2
DO BLD^PSOORUT1
+4 KILL VALMHDR
+5 DO RE^VALM4
+6 QUIT
