- 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 Feb 18, 2025@23:57:42 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