PSOMPHRC ;BIRM/JAM - Patient Medication Profile for HRC - Listmanager ;02/01/11
;;7.0;OUTPATIENT PHARMACY;**382**;DEC 1997;Build 9
;Reference to ^DISV supported by DBIA 510
;Standalone option provided to CAPRI supported by DBIA 4595
;
EN ;Menu option entry point
N PSOEXPDC,PSOEXDCE,PSOSRTBY,PSORDER,PSOSIGDP,PSOSTSGP,PSOSTORD,PSORDCNT,PSOSTSEQ,PSORDSEQ,PSOCHNG
N GRPLN,DIC,Y,DFN,HIGHLN,LASTLINE,VALMCNT,DFN,PSOQIT,WARD,PSODFN,PSOHRC
;
; -- Division selection
I '$G(PSOSITE) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"Pharmacy Division Must be Selected!",! G EXIT
S PSOHRC=1
;
PAT ; -- Patient selection
D EN^PSOPATLK S Y=PSOPTLK
I +Y'>0 G EXIT
S DFN=+Y,PSOQIT=0
D DEM^VADPT I +VADM(6) D G PAT
.W !?10,$C(7),VADM(1)_" ("_VA("PID")_") DIED ON "_$P(VADM(6),"^",2),!
S WARD=$$GET1^DIQ(2,DFN,.1) I WARD]"" D G:PSOQIT PAT
.W !!?10,$C(7),VADM(1)_" ("_VA("PID")_")"
.W !?10,$C(7),"Patient is an Inpatient on Ward "_WARD_" !!"
.W ! D DIR
S PSODFN=DFN D CHKADDR^PSOBAI(DFN,1,1) ;bad address flag/update
;build listman screen ^TMP("PSOPI",$J, for patient information display
D ^PSOORUT2,^PSOBUILD
D LST(PSOSITE,DFN)
G PAT
Q
;
LST(SITE,PSODFN) ; -- ListManager entry point
; Loading Division/User preferences
D LOAD^PSOPMPPF(SITE,DUZ)
W !,"Please wait..."
D EN^VALM("PSO HRC MAIN")
D FULL^VALM1
D EXIT
Q
;
INIT ; -- rebuild ^TMP("PSOPMP0",$J and PSOLST array from ^TMP("PSOPMP0",$J
N NUM,RX,CNT,TYP
D INIT^PSOPMP0
INT ; rebuild PSOLST only
K PSOLST
S (NUM,CNT)=0
F S NUM=$O(^TMP("PSOPMP0",$J,NUM)) Q:'NUM D
.F TYP="RX","PEN","NVA" S RX=$G(^TMP("PSOPMP0",$J,NUM,TYP)) I RX'="" D
..S CNT=CNT+1,PSOLST(CNT)=$S(TYP="RX":52,TYP="PEN":52.41,1:55.05)_"^"_RX_"^"_$P($$STSINFO^PSOPMP1(RX),"^",2)
S PSOCNT=CNT
Q
;
HDR ; -- header code
S VALMHDR(1)="This is a test header for PSO HRC REFILL SELECTION."
S VALMHDR(2)="This is the second line"
Q
;
HDRF ; -- rebuild listman array for Speed refill
I $G(PSOHRCF) D INIT^PSOPMP0
K PSOHRCF
Q
;
SEL ; -- Process selection of RX entries
N PSOSEL,PSOLIS,TYPE,XQORM,ORD,TITLE,XX
S PSOLIS=$P(XQORNOD(0),"=",2) I 'PSOLIS S VALMSG="Invalid selection!",VALMBCK="R" Q
S TITLE=VALM("TITLE")
F XX=1:1:$L(PSOLIS,",") Q:$P(PSOLIS,",",XX)']"" D
.S PSOSEL=+$P(PSOLIS,",",XX) I 'PSOSEL S VALMSG="Invalid selection!" Q
.S TYPE=$O(^TMP("PSOPMP0",$J,PSOSEL,0)) I TYPE="" S VALMSG="Invalid selection!" Q
.S ORD=$G(^TMP("PSOPMP0",$J,PSOSEL,TYPE))
.I 'ORD S VALMSG="Invalid selection!" Q
.D INT
.;
.; -- Regular prescription
.I TYPE="RX" D S VALMBCK="R" D REF^PSOPMP0
.. N STAT,PROACT,LINE,TITLE
.. S (Y,ORN)=PSOSEL,COPY=1
.. D NEWSEL^PSOORNE2,INIT
.. S STAT=$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),100,"I"),PSOACT=$S('STAT:"R",1:""),VALMSG="Enter ?? for more actions"
.. D LG
.;
.; -- Pending Order
.I TYPE="PEN" D S VALMBCK="R" D REF^PSOPMP0
.. N PSOACTOV,OR0,OLVLM,LINE,TITLE
.. S OR0=^PS(52.41,ORD,0),PSOACTOV=1,OLVLM=$$ADPL()
.. D PENHDR^PSOPMP1(PSODFN),DSPL^PSOORFI1
.. I OLVLM S ^DISV(+$G(DUZ),"VALMMENU",$P(OLVLM,"^",2))=OLVLM
.;
.; -- Non-VA Order
.I TYPE="NVA" D
.. N LINE,TITLE D EN^PSONVAVW(PSODFN,ORD)
.;
S VALMBCK="R",VALM("TITLE")=TITLE
Q
;
ACTIONS() ; -- screen actions on active orders
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)
Q 1
;
ADPL() ; -- disable actions for pending orders
N DIC,X,Y,OLVAL,PRCT
S DIC="^ORD(101,",X="PSO PENDING ORDER MENU",DIC(0)="ZN" D ^DIC Q:Y<0 ""
S PRCT=+Y_";ORD(101,",OLVAL=$G(^DISV(+$G(DUZ),"VALMMENU",PRCT)) I OLVAL="" Q ""
I 'OLVAL Q 0_"^"_PRCT
S ^DISV(+$G(DUZ),"VALMMENU",PRCT)=0
Q 1_"^"_PRCT
;
PI ; -- entry point for PSO HRC Patient Information
I '$D(^TMP("PSOPI",$J)) D ^PSOORUT2
D EN^VALM("PSO HRC Patient Information")
S VALMBCK="R"
Q
DD ; -- entry point for PSO HRC DETAILED ALLERGY
D EN^VALM("PSO HRC DETAILED ALLERGY")
Q
;
LG ; -- entry point for PSO HRC REFILL
S (VALMCNT,PSOPF)=$O(^TMP("PSOAO",$J,"A"),-1)
D EN^VALM("PSO HRC REFILL")
Q
DIR ; -- Dir call
N DIR,X,Y
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do You Want To Continue" D ^DIR K DIR
S:'Y PSOQIT=1
K DIRUT,DTOUT,DUOUT
Q
EXIT ;
K ^TMP("PSOPMP0",$J),^TMP("PSOPMPSR",$J),^TMP("PSODA",$J),^TMP("PSONVAVW",$J)
K COPY,DA,PSOCNT,PSONEW,ORN,PSOACT,PSOPF,PSOHRCF
D KVA^VADPT,PTX^PSORX1,EOJ^PSORX1
Q
;
HELP Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOMPHRC 4463 printed Sep 23, 2025@20:07:41 Page 2
PSOMPHRC ;BIRM/JAM - Patient Medication Profile for HRC - Listmanager ;02/01/11
+1 ;;7.0;OUTPATIENT PHARMACY;**382**;DEC 1997;Build 9
+2 ;Reference to ^DISV supported by DBIA 510
+3 ;Standalone option provided to CAPRI supported by DBIA 4595
+4 ;
EN ;Menu option entry point
+1 NEW PSOEXPDC,PSOEXDCE,PSOSRTBY,PSORDER,PSOSIGDP,PSOSTSGP,PSOSTORD,PSORDCNT,PSOSTSEQ,PSORDSEQ,PSOCHNG
+2 NEW GRPLN,DIC,Y,DFN,HIGHLN,LASTLINE,VALMCNT,DFN,PSOQIT,WARD,PSODFN,PSOHRC
+3 ;
+4 ; -- Division selection
+5 IF '$GET(PSOSITE)
DO ^PSOLSET
IF '$DATA(PSOPAR)
WRITE $CHAR(7),!!,"Pharmacy Division Must be Selected!",!
GOTO EXIT
+6 SET PSOHRC=1
+7 ;
PAT ; -- Patient selection
+1 DO EN^PSOPATLK
SET Y=PSOPTLK
+2 IF +Y'>0
GOTO EXIT
+3 SET DFN=+Y
SET PSOQIT=0
+4 DO DEM^VADPT
IF +VADM(6)
Begin DoDot:1
+5 WRITE !?10,$CHAR(7),VADM(1)_" ("_VA("PID")_") DIED ON "_$PIECE(VADM(6),"^",2),!
End DoDot:1
GOTO PAT
+6 SET WARD=$$GET1^DIQ(2,DFN,.1)
IF WARD]""
Begin DoDot:1
+7 WRITE !!?10,$CHAR(7),VADM(1)_" ("_VA("PID")_")"
+8 WRITE !?10,$CHAR(7),"Patient is an Inpatient on Ward "_WARD_" !!"
+9 WRITE !
DO DIR
End DoDot:1
if PSOQIT
GOTO PAT
+10 ;bad address flag/update
SET PSODFN=DFN
DO CHKADDR^PSOBAI(DFN,1,1)
+11 ;build listman screen ^TMP("PSOPI",$J, for patient information display
+12 DO ^PSOORUT2
DO ^PSOBUILD
+13 DO LST(PSOSITE,DFN)
+14 GOTO PAT
+15 QUIT
+16 ;
LST(SITE,PSODFN) ; -- ListManager entry point
+1 ; Loading Division/User preferences
+2 DO LOAD^PSOPMPPF(SITE,DUZ)
+3 WRITE !,"Please wait..."
+4 DO EN^VALM("PSO HRC MAIN")
+5 DO FULL^VALM1
+6 DO EXIT
+7 QUIT
+8 ;
INIT ; -- rebuild ^TMP("PSOPMP0",$J and PSOLST array from ^TMP("PSOPMP0",$J
+1 NEW NUM,RX,CNT,TYP
+2 DO INIT^PSOPMP0
INT ; rebuild PSOLST only
+1 KILL PSOLST
+2 SET (NUM,CNT)=0
+3 FOR
SET NUM=$ORDER(^TMP("PSOPMP0",$JOB,NUM))
if 'NUM
QUIT
Begin DoDot:1
+4 FOR TYP="RX","PEN","NVA"
SET RX=$GET(^TMP("PSOPMP0",$JOB,NUM,TYP))
IF RX'=""
Begin DoDot:2
+5 SET CNT=CNT+1
SET PSOLST(CNT)=$SELECT(TYP="RX":52,TYP="PEN":52.41,1:55.05)_"^"_RX_"^"_$PIECE($$STSINFO^PSOPMP1(RX),"^",2)
End DoDot:2
End DoDot:1
+6 SET PSOCNT=CNT
+7 QUIT
+8 ;
HDR ; -- header code
+1 SET VALMHDR(1)="This is a test header for PSO HRC REFILL SELECTION."
+2 SET VALMHDR(2)="This is the second line"
+3 QUIT
+4 ;
HDRF ; -- rebuild listman array for Speed refill
+1 IF $GET(PSOHRCF)
DO INIT^PSOPMP0
+2 KILL PSOHRCF
+3 QUIT
+4 ;
SEL ; -- Process selection of RX entries
+1 NEW PSOSEL,PSOLIS,TYPE,XQORM,ORD,TITLE,XX
+2 SET PSOLIS=$PIECE(XQORNOD(0),"=",2)
IF 'PSOLIS
SET VALMSG="Invalid selection!"
SET VALMBCK="R"
QUIT
+3 SET TITLE=VALM("TITLE")
+4 FOR XX=1:1:$LENGTH(PSOLIS,",")
if $PIECE(PSOLIS,",",XX)']""
QUIT
Begin DoDot:1
+5 SET PSOSEL=+$PIECE(PSOLIS,",",XX)
IF 'PSOSEL
SET VALMSG="Invalid selection!"
QUIT
+6 SET TYPE=$ORDER(^TMP("PSOPMP0",$JOB,PSOSEL,0))
IF TYPE=""
SET VALMSG="Invalid selection!"
QUIT
+7 SET ORD=$GET(^TMP("PSOPMP0",$JOB,PSOSEL,TYPE))
+8 IF 'ORD
SET VALMSG="Invalid selection!"
QUIT
+9 DO INT
+10 ;
+11 ; -- Regular prescription
+12 IF TYPE="RX"
Begin DoDot:2
+13 NEW STAT,PROACT,LINE,TITLE
+14 SET (Y,ORN)=PSOSEL
SET COPY=1
+15 DO NEWSEL^PSOORNE2
DO INIT
+16 SET STAT=$$GET1^DIQ(52,$PIECE(PSOLST(ORN),"^",2),100,"I")
SET PSOACT=$SELECT('STAT:"R",1:"")
SET VALMSG="Enter ?? for more actions"
+17 DO LG
End DoDot:2
SET VALMBCK="R"
DO REF^PSOPMP0
+18 ;
+19 ; -- Pending Order
+20 IF TYPE="PEN"
Begin DoDot:2
+21 NEW PSOACTOV,OR0,OLVLM,LINE,TITLE
+22 SET OR0=^PS(52.41,ORD,0)
SET PSOACTOV=1
SET OLVLM=$$ADPL()
+23 DO PENHDR^PSOPMP1(PSODFN)
DO DSPL^PSOORFI1
+24 IF OLVLM
SET ^DISV(+$GET(DUZ),"VALMMENU",$PIECE(OLVLM,"^",2))=OLVLM
End DoDot:2
SET VALMBCK="R"
DO REF^PSOPMP0
+25 ;
+26 ; -- Non-VA Order
+27 IF TYPE="NVA"
Begin DoDot:2
+28 NEW LINE,TITLE
DO EN^PSONVAVW(PSODFN,ORD)
End DoDot:2
+29 ;
End DoDot:1
+30 SET VALMBCK="R"
SET VALM("TITLE")=TITLE
+31 QUIT
+32 ;
ACTIONS() ; -- screen actions on active orders
+1 NEW DIC,X,Y
+2 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 QUIT 1
+6 ;
ADPL() ; -- disable actions for pending orders
+1 NEW DIC,X,Y,OLVAL,PRCT
+2 SET DIC="^ORD(101,"
SET X="PSO PENDING ORDER MENU"
SET DIC(0)="ZN"
DO ^DIC
if Y<0
QUIT ""
+3 SET PRCT=+Y_";ORD(101,"
SET OLVAL=$GET(^DISV(+$GET(DUZ),"VALMMENU",PRCT))
IF OLVAL=""
QUIT ""
+4 IF 'OLVAL
QUIT 0_"^"_PRCT
+5 SET ^DISV(+$GET(DUZ),"VALMMENU",PRCT)=0
+6 QUIT 1_"^"_PRCT
+7 ;
PI ; -- entry point for PSO HRC Patient Information
+1 IF '$DATA(^TMP("PSOPI",$JOB))
DO ^PSOORUT2
+2 DO EN^VALM("PSO HRC Patient Information")
+3 SET VALMBCK="R"
+4 QUIT
DD ; -- entry point for PSO HRC DETAILED ALLERGY
+1 DO EN^VALM("PSO HRC DETAILED ALLERGY")
+2 QUIT
+3 ;
LG ; -- entry point for PSO HRC REFILL
+1 SET (VALMCNT,PSOPF)=$ORDER(^TMP("PSOAO",$JOB,"A"),-1)
+2 DO EN^VALM("PSO HRC REFILL")
+3 QUIT
DIR ; -- Dir call
+1 NEW DIR,X,Y
+2 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Do You Want To Continue"
DO ^DIR
KILL DIR
+3 if 'Y
SET PSOQIT=1
+4 KILL DIRUT,DTOUT,DUOUT
+5 QUIT
EXIT ;
+1 KILL ^TMP("PSOPMP0",$JOB),^TMP("PSOPMPSR",$JOB),^TMP("PSODA",$JOB),^TMP("PSONVAVW",$JOB)
+2 KILL COPY,DA,PSOCNT,PSONEW,ORN,PSOACT,PSOPF,PSOHRCF
+3 DO KVA^VADPT
DO PTX^PSORX1
DO EOJ^PSORX1
+4 QUIT
+5 ;
HELP QUIT
