PSONVAR1 ;BHM/MFR - Non-VA Med Usage Report ;Mar 13, 2020@16:01:15
;;7.0;OUTPATIENT PHARMACY;**132,118,441**;DEC 1997;Build 208
;External reference to File ^PS(55 supported by DBIA 2228
;External reference to $$GET1^DIQ is supported by DBIA 2056
;External reference to ^VADPT is supported by DBIA 10061
;External reference to ^XLFDT is supported by DBIA 10103
;External reference to ^%ZISC is supported by DBIA 10089
;
;Add complex orders to NVA Meds
;
EN N DATE,DFN,ORD,PAG,PCNT,PRTD,OINAM,PNAM,I,J,Y,X,C,XX,S1,S2,S3,S4,S5,OCNT
N OCK,OK,STS,SUB,SP1,SP2,SPF
;
U IO K ^TMP("PSONV",$J),^TMP("PSOCNT",$J)
S SPF=0,(SP1,SP2)="",$P(SP1,"=",80)="",$P(SP2,"-",80)=""
;
; - Loop through the Non-VA Med orders x-reference
S DATE=PSOSD,(DFN,ORD)="",(PCNT,OCNT,PRTD)=0 K DIRUT
DATE S DATE=$O(^PS(55,"ADCDT",DATE)) G NEXT:DATE=""!(DATE>PSOED)
W:SPF SP1
;
DFN I PSOAPT S DFN=$O(^PS(55,"ADCDT",DATE,DFN)) G DATE:DFN=""
I 'PSOAPT S DFN=$O(PSOPT(DFN)) G DATE:DFN="" ;Patient Filter
;
I $$DEAD^PSONVARP(DFN) G DFN ;Patient is Dead
;
ORD S ORD=$O(^PS(55,"ADCDT",DATE,DFN,ORD)) G DFN:ORD=""
S XX=$G(^PS(55,DFN,"NVA",ORD,0))
I 'PSOAOI,'$D(PSOOI(+$P(XX,"^"))) G ORD ;OI Filter
I '$P(XX,"^",6),PSOST="D" G ORD ;Status Filter
I $P(XX,"^",6),PSOST="A" G ORD
I '$D(^PS(55,DFN,"NVA",ORD,"OCK")),PSOOC="Y" G ORD ;Order Checks Filter
I $D(^PS(55,DFN,"NVA",ORD,"OCK")),PSOOC="N" G ORD
;
I PSOSRT=3 D G CLOSE:$D(DIRUT),ORD ;If not Sorting,
. I $Y>(IOSL-9) D HDR I $D(DIRUT) Q ;Print the Report
. D PRINT(DFN,ORD) Q:$D(DIRUT) S SPF=1 ;Then G ORD
;
I PSOSRT[1 S PNAM=$$GET1^DIQ(2,DFN,.01) ;Retrieving Patient
I PSOSRT[2 S OINAM=$$GET1^DIQ(50.7,+$P(XX,"^"),.01) ;Name and Orderable
S:$G(PNAM)="" PNAM=0 S:$G(OINAM)="" OINAM=0 ;Item Name
S (S1,S2,S3,S4,S5)=0
F I=1:1:$L(PSOSRT,",") D
. S Y=$P(PSOSRT,",",I),STS=+$P(XX,"^",6)
. S OCK=$S($D(^PS(55,DFN,"NVA",ORD,"OCK")):1,1:2)
. S @("S"_I)=$S(Y=1:PNAM,Y=2:OINAM,Y=3:DATE,Y=4:+STS,Y=5:OCK)
S ^TMP("PSONV",$J,S1,S2,S3,S4,S5,DFN,ORD)=""
G ORD
;
NEXT ; - If not Sorting (already printed), SKIP, otherwise, print the report
I PSOSRT="" G NDTP
S (S1,S2,S3,S4,S5,DFN,ORD)=""
F S S1=$O(^TMP("PSONV",$J,S1)) Q:S1="" D Q:$D(DIRUT)
. F S S2=$O(^TMP("PSONV",$J,S1,S2)) Q:S2="" D Q:$D(DIRUT)
. . F S S3=$O(^TMP("PSONV",$J,S1,S2,S3)) Q:S3="" D Q:$D(DIRUT)
. . . F S S4=$O(^TMP("PSONV",$J,S1,S2,S3,S4)) Q:S4="" D Q:$D(DIRUT)
. . . . F S S5=$O(^TMP("PSONV",$J,S1,S2,S3,S4,S5)) Q:S5="" D Q:$D(DIRUT)
. . . . . F S DFN=$O(^TMP("PSONV",$J,S1,S2,S3,S4,S5,DFN)) Q:DFN="" D Q:$D(DIRUT)
. . . . . . F S ORD=$O(^TMP("PSONV",$J,S1,S2,S3,S4,S5,DFN,ORD)) Q:ORD="" D Q:$D(DIRUT)
. . . . . . . I $Y>(IOSL-12) D HDR I $D(DIRUT) Q
. . . . . . . D PRINT(DFN,ORD)
. . I '$D(DIRUT),S2'=0,$O(^TMP("PSONV",$J,S1,S2))'="" W SP2
. I '$D(DIRUT),$O(^TMP("PSONV",$J,S1))'="" W SP1
G CLOSE:$D(DIRUT)
;
NDTP I 'PRTD D HDR W !!?18,"********** NO DATA TO PRINT **********"
I PRTD D
. W SP1
. W !,"Total: ",PCNT," patient",$S(PCNT>1:"s",1:"")
. W " and ",OCNT," order",$S(OCNT>1:"s",1:""),"."
. D HDR Q:$D(DIRUT) ;pause for reading of total before scrolls away...
;
CLOSE D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
END K ^TMP("PSONV",$J),^TMP("PSOCNT",$J)
Q
;
PRINT(DFN,ORD) ; - Print a Non-VA Med Order
;Input: DFN-Patient;ORD-Non-VA Order#
N X,XX,K,OI,OIX,OINAM,DGNAM,PNAM,PSSN,CLNAM,PRV,I,J,Z,TXT,VAPA,VADM,SCH
N STR,OCK
;
I '$D(^PS(55,DFN,"NVA",ORD)) Q
I '$G(PAG) D HDR I $D(DIRUT) Q
;
S XX=^PS(55,DFN,"NVA",ORD,0),OINAM=$$GET1^DIQ(50.7,+$P(XX,"^"),.01)
S DGNAM="" I $P(XX,"^",2) S DGNAM=$$GET1^DIQ(50,+$P(XX,"^",2),.01)
D DEM^VADPT,ADD^VADPT S PNAM=$P(VADM(1),"^"),PSSN=$P($G(VADM(2)),"^",2)
W !,PNAM," (ID:",$S(PSSN:$P(PSSN,"-",3),1:"0000"),")"
W ?46,"Patient Phone #: ",$E($P(VAPA(8),"^"),1,16)
S:'$D(^TMP("PSOCNT",$J,DFN)) PCNT=PCNT+1 S ^TMP("PSOCNT",$J,DFN)=""
;
W !?5,"Non-VA Med: ",OINAM
D PRTDDR ;print dispense drug line(s)
W !?9,"Status: ",$S('$P(XX,"^",6):"ACTIVE",1:"DISCONTINUED on "_$$DT($P(XX,"^",7)))
W ?49,"CPRS Order #: ",$P(XX,"^",8)
W !?2,"Documented By: ",$E($$GET1^DIQ(200,+$P(XX,"^",11),.01),1,29)
W ?46,"Documented Date: ",$$DT($P(XX,"^",10))
S CLNAM=$$GET1^DIQ(44,+$P(XX,"^",12),.01)
W !?9,"Clinic: " W:$P(XX,"^",12) $E($P(XX,"^",12)_" - "_CLNAM,1,33)
W ?51,"Start Date: ",$$DT($P(XX,"^",9)),!
W ?5,"Indication: ",$P($G(^PS(55,DFN,"NVA",ORD,2)),"^"),! ;*441-IND
I $Y>(IOSL-4) D HDR Q:$D(DIRUT) W !
;
; - Printing "Order Checks" fields
W:$D(^PS(55,DFN,"NVA",ORD,"OCK")) !
F I=0:0 S I=$O(^PS(55,DFN,"NVA",ORD,"OCK",I)) Q:'I D Q:$D(DIRUT)
. S OCK=^PS(55,DFN,"NVA",ORD,"OCK",I,0),STR=$P(OCK,"^"),PRV=+$P(OCK,"^",2)
. I $Y>(IOSL-5) D HDR Q:$D(DIRUT) W !
. W ?1,"Order Check #",I,": " K TXT D TEXT(.TXT,STR,61)
. F K=1:1 Q:'$D(TXT(K)) D Q:$D(DIRUT)
. . W ?17,TXT(K),! I $Y>(IOSL-4) D HDR Q:$D(DIRUT) W !
. Q:$D(DIRUT) K TXT
. F J=0:0 S J=$O(^PS(55,DFN,"NVA",ORD,"OCK",I,"OVR",J)) Q:'J D
. . S STR=^PS(55,DFN,"NVA",ORD,"OCK",I,"OVR",J,0)
. . D TEXT(.TXT,STR,56)
. W ?6,"Override Reason: " W:'$D(TXT) !
. F K=1:1 Q:'$D(TXT(K)) D Q:$D(DIRUT)
. . W ?23,TXT(K),! I $Y>(IOSL-4) D HDR Q:$D(DIRUT) W !
. Q:$D(DIRUT)
. W ?6,"Override Provider: " W:PRV $$GET1^DIQ(200,+PRV,.01) W !
Q:$D(DIRUT)
;
; - Printing "Statement/Explanation/Comments" field
I $D(^PS(55,DFN,"NVA",ORD,"DSC")) D Q:$D(DIRUT)
. W !,"Statement/Explanation/Comments: " K TXT
. F I=0:0 S I=$O(^PS(55,DFN,"NVA",ORD,"DSC",I)) Q:'I D
. . S STR=^PS(55,DFN,"NVA",ORD,"DSC",I,0)
. . D TEXT(.TXT,STR,47)
. F K=1:1 Q:'$D(TXT(K)) D Q:$D(DIRUT)
. . W ?32,TXT(K),! I $Y>(IOSL-4) D HDR Q:$D(DIRUT) W !
;
S PRTD=1,OCNT=OCNT+1
Q
;
PRTDDR ;Print Dispense Drug item(s) including complex orders with conjunctions from SIG multiple
; This multiple replaces using the parent 0 node fields DD, DOSE, MED RTE, & SCHED for printing, However,
; if OLD recorsd found, i.e. no new 55.516 multiple, then use OLD print method for backwards compatibility
N DDR,DDX,DDR05,DDR15,REC,SCHX,SCHY
S REC=$S($O(^PS(55,DFN,"NVA",ORD,3,0)):"NEW",1:"OLD") ;NEW multiple found or Not, OLD
;Rec=OLD - Data Dic orders created pre *441 version, backwards compatibility
I REC="OLD" D Q
. W !?2,"Dispense Drug: ",$E(DGNAM,1,37)
. W ?55,"Dosage: ",$E($P(XX,"^",3),1,16)
. W !?7,"Schedule: " S X=$E($P(XX,"^",5),1,30)
. S SCH=$S($L($P(XX,"^",5))>30:$P(X," ",1,$L(X," ")-1),1:X) W SCH
. W ?52,"Med Route: ",$E($P(XX,"^",4),1,35)
. I $E($P(XX,"^",5),$L(SCH)+1,99)'="" D
. . W !?16,$E($P(XX,"^",5),$L(SCH)+1,99)
;Rec=NEW -Data Dic orders created post
S DDR=0
F S DDR=$O(^PS(55,DFN,"NVA",ORD,3,DDR)) Q:'DDR D
. S DDR05=ORD_","_DFN,DDR15=DDR_","_DDR05
. S DGNAM="",DDX=+$$GET1^DIQ(55.05,DDR05,"DISPENSE DRUG","I") S:DDX DGNAM=$$GET1^DIQ(50,DDX,.01)
. W !?2,"Dispense Drug: ",$E(DGNAM,1,37),?55,"Dosage: ",$E($$GET1^DIQ(55.516,DDR15,"DOSAGE"),1,16) I $Y>(IOSL-4) D HDR Q:$D(DIRUT) W !
. S SCHX=$$GET1^DIQ(55.516,DDR15,"SCHEDULE"),SCHY=$E(SCHX,1,34),SCH=$S($L(SCHX)>34:$P(SCHY," ",1,$L(SCHY," ")-1),1:SCHY)
. W !?7,"Schedule: ",SCH,?52,"Med Route: ",$E($$GET1^DIQ(55.516,DDR15,"MEDICATION ROUTE"),1,35) I $Y>(IOSL-4) D HDR Q:$D(DIRUT) W !
. I $E(SCHX,$L(SCH)+1,99)'="" D
. . W !?16,$E(SCHX,$L(SCH)+1,99) I $Y>(IOSL-4) D HDR Q:$D(DIRUT) W !
. ;add below 2 new fields to report
. W !?7,"Duration: ",$E($$GET1^DIQ(55.516,DDR15,"DURATION"),1,37),?50,"Conjunction: ",$E($$GET1^DIQ(55.516,DDR15,"CONJUNCTION"),1,16)
. I $Y>(IOSL-4) D HDR Q:$D(DIRUT) W !
Q
;
TEXT(TEXT,STR,L) ; Formats STR into TEXT array, lines lenght = L
N J,WORD,K S K=+$O(TEXT(""),-1) S:'K K=1
F J=1:1:$L(STR," ") D
. S WORD=$P(STR," ",J) I ($L($G(TEXT(K))_WORD))>L S K=K+1
. S TEXT(K)=$G(TEXT(K))_WORD_" "
Q
;
HDR ; - Prints the Header
N X,DIR S PAG=$G(PAG)+1
I PAG>1,$E(IOST)="C" D Q:$D(DIRUT)
. S DIR(0)="E",DIR("A")=" Press ENTER to Continue or ^ to Exit" D ^DIR
;
W @IOF,"Non-VA Meds Usage Report",?70,"Page: ",$J(PAG,3)
W !,"Sorted by",$$SRT(PSOSRT)
W !,"Date Range: "_$$DT(PSOSD+1\1)_" - "_$$DT(PSOED\1)
W ?48,"Run Date: "_$$FMTE^XLFDT($$NOW^XLFDT())
S X="",$P(X,"-",80)="" W !,X
Q
;
SRT(ST) ; - Convert the "1,2,4" (example) to "PATIENT,ORDERABLE ITEM,STATUS"
;Input: ST-String with the Sorting fields by number
;Output: ST-String with the Sorting fields by name
N I,X,STR,FLD
S STR="PATIENT NAME^ORDERABLE ITEM^DATE DOCUMENTED^STATUS^ORDER CHECKS"
F I=1:1:$L(ST,",") D
. S FLD=+$P(ST,",",I),X=$P(STR,"^",FLD)
. S $P(ST,",",I)=" "_X
Q ST
;
DT(DT) ; - Convert FM Date to MM/DD/YYYY
I 'DT Q ""
I '(DT#10000) Q (1700+$E(DT,1,3))
I '(DT#100) Q $E(DT,4,5)_"/"_(1700+$E(DT,1,3))
Q $E(DT,4,5)_"/"_$E(DT,6,7)_"/"_(1700+$E(DT,1,3))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSONVAR1 8947 printed Sep 23, 2025@20:08:01 Page 2
PSONVAR1 ;BHM/MFR - Non-VA Med Usage Report ;Mar 13, 2020@16:01:15
+1 ;;7.0;OUTPATIENT PHARMACY;**132,118,441**;DEC 1997;Build 208
+2 ;External reference to File ^PS(55 supported by DBIA 2228
+3 ;External reference to $$GET1^DIQ is supported by DBIA 2056
+4 ;External reference to ^VADPT is supported by DBIA 10061
+5 ;External reference to ^XLFDT is supported by DBIA 10103
+6 ;External reference to ^%ZISC is supported by DBIA 10089
+7 ;
+8 ;Add complex orders to NVA Meds
+9 ;
EN NEW DATE,DFN,ORD,PAG,PCNT,PRTD,OINAM,PNAM,I,J,Y,X,C,XX,S1,S2,S3,S4,S5,OCNT
+1 NEW OCK,OK,STS,SUB,SP1,SP2,SPF
+2 ;
+3 USE IO
KILL ^TMP("PSONV",$JOB),^TMP("PSOCNT",$JOB)
+4 SET SPF=0
SET (SP1,SP2)=""
SET $PIECE(SP1,"=",80)=""
SET $PIECE(SP2,"-",80)=""
+5 ;
+6 ; - Loop through the Non-VA Med orders x-reference
+7 SET DATE=PSOSD
SET (DFN,ORD)=""
SET (PCNT,OCNT,PRTD)=0
KILL DIRUT
DATE SET DATE=$ORDER(^PS(55,"ADCDT",DATE))
if DATE=""!(DATE>PSOED)
GOTO NEXT
+1 if SPF
WRITE SP1
+2 ;
DFN IF PSOAPT
SET DFN=$ORDER(^PS(55,"ADCDT",DATE,DFN))
if DFN=""
GOTO DATE
+1 ;Patient Filter
IF 'PSOAPT
SET DFN=$ORDER(PSOPT(DFN))
if DFN=""
GOTO DATE
+2 ;
+3 ;Patient is Dead
IF $$DEAD^PSONVARP(DFN)
GOTO DFN
+4 ;
ORD SET ORD=$ORDER(^PS(55,"ADCDT",DATE,DFN,ORD))
if ORD=""
GOTO DFN
+1 SET XX=$GET(^PS(55,DFN,"NVA",ORD,0))
+2 ;OI Filter
IF 'PSOAOI
IF '$DATA(PSOOI(+$PIECE(XX,"^")))
GOTO ORD
+3 ;Status Filter
IF '$PIECE(XX,"^",6)
IF PSOST="D"
GOTO ORD
+4 IF $PIECE(XX,"^",6)
IF PSOST="A"
GOTO ORD
+5 ;Order Checks Filter
IF '$DATA(^PS(55,DFN,"NVA",ORD,"OCK"))
IF PSOOC="Y"
GOTO ORD
+6 IF $DATA(^PS(55,DFN,"NVA",ORD,"OCK"))
IF PSOOC="N"
GOTO ORD
+7 ;
+8 ;If not Sorting,
IF PSOSRT=3
Begin DoDot:1
+9 ;Print the Report
IF $Y>(IOSL-9)
DO HDR
IF $DATA(DIRUT)
QUIT
+10 ;Then G ORD
DO PRINT(DFN,ORD)
if $DATA(DIRUT)
QUIT
SET SPF=1
End DoDot:1
if $DATA(DIRUT)
GOTO CLOSE
GOTO ORD
+11 ;
+12 ;Retrieving Patient
IF PSOSRT[1
SET PNAM=$$GET1^DIQ(2,DFN,.01)
+13 ;Name and Orderable
IF PSOSRT[2
SET OINAM=$$GET1^DIQ(50.7,+$PIECE(XX,"^"),.01)
+14 ;Item Name
if $GET(PNAM)=""
SET PNAM=0
if $GET(OINAM)=""
SET OINAM=0
+15 SET (S1,S2,S3,S4,S5)=0
+16 FOR I=1:1:$LENGTH(PSOSRT,",")
Begin DoDot:1
+17 SET Y=$PIECE(PSOSRT,",",I)
SET STS=+$PIECE(XX,"^",6)
+18 SET OCK=$SELECT($DATA(^PS(55,DFN,"NVA",ORD,"OCK")):1,1:2)
+19 SET @("S"_I)=$SELECT(Y=1:PNAM,Y=2:OINAM,Y=3:DATE,Y=4:+STS,Y=5:OCK)
End DoDot:1
+20 SET ^TMP("PSONV",$JOB,S1,S2,S3,S4,S5,DFN,ORD)=""
+21 GOTO ORD
+22 ;
NEXT ; - If not Sorting (already printed), SKIP, otherwise, print the report
+1 IF PSOSRT=""
GOTO NDTP
+2 SET (S1,S2,S3,S4,S5,DFN,ORD)=""
+3 FOR
SET S1=$ORDER(^TMP("PSONV",$JOB,S1))
if S1=""
QUIT
Begin DoDot:1
+4 FOR
SET S2=$ORDER(^TMP("PSONV",$JOB,S1,S2))
if S2=""
QUIT
Begin DoDot:2
+5 FOR
SET S3=$ORDER(^TMP("PSONV",$JOB,S1,S2,S3))
if S3=""
QUIT
Begin DoDot:3
+6 FOR
SET S4=$ORDER(^TMP("PSONV",$JOB,S1,S2,S3,S4))
if S4=""
QUIT
Begin DoDot:4
+7 FOR
SET S5=$ORDER(^TMP("PSONV",$JOB,S1,S2,S3,S4,S5))
if S5=""
QUIT
Begin DoDot:5
+8 FOR
SET DFN=$ORDER(^TMP("PSONV",$JOB,S1,S2,S3,S4,S5,DFN))
if DFN=""
QUIT
Begin DoDot:6
+9 FOR
SET ORD=$ORDER(^TMP("PSONV",$JOB,S1,S2,S3,S4,S5,DFN,ORD))
if ORD=""
QUIT
Begin DoDot:7
+10 IF $Y>(IOSL-12)
DO HDR
IF $DATA(DIRUT)
QUIT
+11 DO PRINT(DFN,ORD)
End DoDot:7
if $DATA(DIRUT)
QUIT
End DoDot:6
if $DATA(DIRUT)
QUIT
End DoDot:5
if $DATA(DIRUT)
QUIT
End DoDot:4
if $DATA(DIRUT)
QUIT
End DoDot:3
if $DATA(DIRUT)
QUIT
+12 IF '$DATA(DIRUT)
IF S2'=0
IF $ORDER(^TMP("PSONV",$JOB,S1,S2))'=""
WRITE SP2
End DoDot:2
if $DATA(DIRUT)
QUIT
+13 IF '$DATA(DIRUT)
IF $ORDER(^TMP("PSONV",$JOB,S1))'=""
WRITE SP1
End DoDot:1
if $DATA(DIRUT)
QUIT
+14 if $DATA(DIRUT)
GOTO CLOSE
+15 ;
NDTP IF 'PRTD
DO HDR
WRITE !!?18,"********** NO DATA TO PRINT **********"
+1 IF PRTD
Begin DoDot:1
+2 WRITE SP1
+3 WRITE !,"Total: ",PCNT," patient",$SELECT(PCNT>1:"s",1:"")
+4 WRITE " and ",OCNT," order",$SELECT(OCNT>1:"s",1:""),"."
+5 ;pause for reading of total before scrolls away...
DO HDR
if $DATA(DIRUT)
QUIT
End DoDot:1
+6 ;
CLOSE DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
END KILL ^TMP("PSONV",$JOB),^TMP("PSOCNT",$JOB)
+1 QUIT
+2 ;
PRINT(DFN,ORD) ; - Print a Non-VA Med Order
+1 ;Input: DFN-Patient;ORD-Non-VA Order#
+2 NEW X,XX,K,OI,OIX,OINAM,DGNAM,PNAM,PSSN,CLNAM,PRV,I,J,Z,TXT,VAPA,VADM,SCH
+3 NEW STR,OCK
+4 ;
+5 IF '$DATA(^PS(55,DFN,"NVA",ORD))
QUIT
+6 IF '$GET(PAG)
DO HDR
IF $DATA(DIRUT)
QUIT
+7 ;
+8 SET XX=^PS(55,DFN,"NVA",ORD,0)
SET OINAM=$$GET1^DIQ(50.7,+$PIECE(XX,"^"),.01)
+9 SET DGNAM=""
IF $PIECE(XX,"^",2)
SET DGNAM=$$GET1^DIQ(50,+$PIECE(XX,"^",2),.01)
+10 DO DEM^VADPT
DO ADD^VADPT
SET PNAM=$PIECE(VADM(1),"^")
SET PSSN=$PIECE($GET(VADM(2)),"^",2)
+11 WRITE !,PNAM," (ID:",$SELECT(PSSN:$PIECE(PSSN,"-",3),1:"0000"),")"
+12 WRITE ?46,"Patient Phone #: ",$EXTRACT($PIECE(VAPA(8),"^"),1,16)
+13 if '$DATA(^TMP("PSOCNT",$JOB,DFN))
SET PCNT=PCNT+1
SET ^TMP("PSOCNT",$JOB,DFN)=""
+14 ;
+15 WRITE !?5,"Non-VA Med: ",OINAM
+16 ;print dispense drug line(s)
DO PRTDDR
+17 WRITE !?9,"Status: ",$SELECT('$PIECE(XX,"^",6):"ACTIVE",1:"DISCONTINUED on "_$$DT($PIECE(XX,"^",7)))
+18 WRITE ?49,"CPRS Order #: ",$PIECE(XX,"^",8)
+19 WRITE !?2,"Documented By: ",$EXTRACT($$GET1^DIQ(200,+$PIECE(XX,"^",11),.01),1,29)
+20 WRITE ?46,"Documented Date: ",$$DT($PIECE(XX,"^",10))
+21 SET CLNAM=$$GET1^DIQ(44,+$PIECE(XX,"^",12),.01)
+22 WRITE !?9,"Clinic: "
if $PIECE(XX,"^",12)
WRITE $EXTRACT($PIECE(XX,"^",12)_" - "_CLNAM,1,33)
+23 WRITE ?51,"Start Date: ",$$DT($PIECE(XX,"^",9)),!
+24 ;*441-IND
WRITE ?5,"Indication: ",$PIECE($GET(^PS(55,DFN,"NVA",ORD,2)),"^"),!
+25 IF $Y>(IOSL-4)
DO HDR
if $DATA(DIRUT)
QUIT
WRITE !
+26 ;
+27 ; - Printing "Order Checks" fields
+28 if $DATA(^PS(55,DFN,"NVA",ORD,"OCK"))
WRITE !
+29 FOR I=0:0
SET I=$ORDER(^PS(55,DFN,"NVA",ORD,"OCK",I))
if 'I
QUIT
Begin DoDot:1
+30 SET OCK=^PS(55,DFN,"NVA",ORD,"OCK",I,0)
SET STR=$PIECE(OCK,"^")
SET PRV=+$PIECE(OCK,"^",2)
+31 IF $Y>(IOSL-5)
DO HDR
if $DATA(DIRUT)
QUIT
WRITE !
+32 WRITE ?1,"Order Check #",I,": "
KILL TXT
DO TEXT(.TXT,STR,61)
+33 FOR K=1:1
if '$DATA(TXT(K))
QUIT
Begin DoDot:2
+34 WRITE ?17,TXT(K),!
IF $Y>(IOSL-4)
DO HDR
if $DATA(DIRUT)
QUIT
WRITE !
End DoDot:2
if $DATA(DIRUT)
QUIT
+35 if $DATA(DIRUT)
QUIT
KILL TXT
+36 FOR J=0:0
SET J=$ORDER(^PS(55,DFN,"NVA",ORD,"OCK",I,"OVR",J))
if 'J
QUIT
Begin DoDot:2
+37 SET STR=^PS(55,DFN,"NVA",ORD,"OCK",I,"OVR",J,0)
+38 DO TEXT(.TXT,STR,56)
End DoDot:2
+39 WRITE ?6,"Override Reason: "
if '$DATA(TXT)
WRITE !
+40 FOR K=1:1
if '$DATA(TXT(K))
QUIT
Begin DoDot:2
+41 WRITE ?23,TXT(K),!
IF $Y>(IOSL-4)
DO HDR
if $DATA(DIRUT)
QUIT
WRITE !
End DoDot:2
if $DATA(DIRUT)
QUIT
+42 if $DATA(DIRUT)
QUIT
+43 WRITE ?6,"Override Provider: "
if PRV
WRITE $$GET1^DIQ(200,+PRV,.01)
WRITE !
End DoDot:1
if $DATA(DIRUT)
QUIT
+44 if $DATA(DIRUT)
QUIT
+45 ;
+46 ; - Printing "Statement/Explanation/Comments" field
+47 IF $DATA(^PS(55,DFN,"NVA",ORD,"DSC"))
Begin DoDot:1
+48 WRITE !,"Statement/Explanation/Comments: "
KILL TXT
+49 FOR I=0:0
SET I=$ORDER(^PS(55,DFN,"NVA",ORD,"DSC",I))
if 'I
QUIT
Begin DoDot:2
+50 SET STR=^PS(55,DFN,"NVA",ORD,"DSC",I,0)
+51 DO TEXT(.TXT,STR,47)
End DoDot:2
+52 FOR K=1:1
if '$DATA(TXT(K))
QUIT
Begin DoDot:2
+53 WRITE ?32,TXT(K),!
IF $Y>(IOSL-4)
DO HDR
if $DATA(DIRUT)
QUIT
WRITE !
End DoDot:2
if $DATA(DIRUT)
QUIT
End DoDot:1
if $DATA(DIRUT)
QUIT
+54 ;
+55 SET PRTD=1
SET OCNT=OCNT+1
+56 QUIT
+57 ;
PRTDDR ;Print Dispense Drug item(s) including complex orders with conjunctions from SIG multiple
+1 ; This multiple replaces using the parent 0 node fields DD, DOSE, MED RTE, & SCHED for printing, However,
+2 ; if OLD recorsd found, i.e. no new 55.516 multiple, then use OLD print method for backwards compatibility
+3 NEW DDR,DDX,DDR05,DDR15,REC,SCHX,SCHY
+4 ;NEW multiple found or Not, OLD
SET REC=$SELECT($ORDER(^PS(55,DFN,"NVA",ORD,3,0)):"NEW",1:"OLD")
+5 ;Rec=OLD - Data Dic orders created pre *441 version, backwards compatibility
+6 IF REC="OLD"
Begin DoDot:1
+7 WRITE !?2,"Dispense Drug: ",$EXTRACT(DGNAM,1,37)
+8 WRITE ?55,"Dosage: ",$EXTRACT($PIECE(XX,"^",3),1,16)
+9 WRITE !?7,"Schedule: "
SET X=$EXTRACT($PIECE(XX,"^",5),1,30)
+10 SET SCH=$SELECT($LENGTH($PIECE(XX,"^",5))>30:$PIECE(X," ",1,$LENGTH(X," ")-1),1:X)
WRITE SCH
+11 WRITE ?52,"Med Route: ",$EXTRACT($PIECE(XX,"^",4),1,35)
+12 IF $EXTRACT($PIECE(XX,"^",5),$LENGTH(SCH)+1,99)'=""
Begin DoDot:2
+13 WRITE !?16,$EXTRACT($PIECE(XX,"^",5),$LENGTH(SCH)+1,99)
End DoDot:2
End DoDot:1
QUIT
+14 ;Rec=NEW -Data Dic orders created post
+15 SET DDR=0
+16 FOR
SET DDR=$ORDER(^PS(55,DFN,"NVA",ORD,3,DDR))
if 'DDR
QUIT
Begin DoDot:1
+17 SET DDR05=ORD_","_DFN
SET DDR15=DDR_","_DDR05
+18 SET DGNAM=""
SET DDX=+$$GET1^DIQ(55.05,DDR05,"DISPENSE DRUG","I")
if DDX
SET DGNAM=$$GET1^DIQ(50,DDX,.01)
+19 WRITE !?2,"Dispense Drug: ",$EXTRACT(DGNAM,1,37),?55,"Dosage: ",$EXTRACT($$GET1^DIQ(55.516,DDR15,"DOSAGE"),1,16)
IF $Y>(IOSL-4)
DO HDR
if $DATA(DIRUT)
QUIT
WRITE !
+20 SET SCHX=$$GET1^DIQ(55.516,DDR15,"SCHEDULE")
SET SCHY=$EXTRACT(SCHX,1,34)
SET SCH=$SELECT($LENGTH(SCHX)>34:$PIECE(SCHY," ",1,$LENGTH(SCHY," ")-1),1:SCHY)
+21 WRITE !?7,"Schedule: ",SCH,?52,"Med Route: ",$EXTRACT($$GET1^DIQ(55.516,DDR15,"MEDICATION ROUTE"),1,35)
IF $Y>(IOSL-4)
DO HDR
if $DATA(DIRUT)
QUIT
WRITE !
+22 IF $EXTRACT(SCHX,$LENGTH(SCH)+1,99)'=""
Begin DoDot:2
+23 WRITE !?16,$EXTRACT(SCHX,$LENGTH(SCH)+1,99)
IF $Y>(IOSL-4)
DO HDR
if $DATA(DIRUT)
QUIT
WRITE !
End DoDot:2
+24 ;add below 2 new fields to report
+25 WRITE !?7,"Duration: ",$EXTRACT($$GET1^DIQ(55.516,DDR15,"DURATION"),1,37),?50,"Conjunction: ",$EXTRACT($$GET1^DIQ(55.516,DDR15,"CONJUNCTION"),1,16)
+26 IF $Y>(IOSL-4)
DO HDR
if $DATA(DIRUT)
QUIT
WRITE !
End DoDot:1
+27 QUIT
+28 ;
TEXT(TEXT,STR,L) ; Formats STR into TEXT array, lines lenght = L
+1 NEW J,WORD,K
SET K=+$ORDER(TEXT(""),-1)
if 'K
SET K=1
+2 FOR J=1:1:$LENGTH(STR," ")
Begin DoDot:1
+3 SET WORD=$PIECE(STR," ",J)
IF ($LENGTH($GET(TEXT(K))_WORD))>L
SET K=K+1
+4 SET TEXT(K)=$GET(TEXT(K))_WORD_" "
End DoDot:1
+5 QUIT
+6 ;
HDR ; - Prints the Header
+1 NEW X,DIR
SET PAG=$GET(PAG)+1
+2 IF PAG>1
IF $EXTRACT(IOST)="C"
Begin DoDot:1
+3 SET DIR(0)="E"
SET DIR("A")=" Press ENTER to Continue or ^ to Exit"
DO ^DIR
End DoDot:1
if $DATA(DIRUT)
QUIT
+4 ;
+5 WRITE @IOF,"Non-VA Meds Usage Report",?70,"Page: ",$JUSTIFY(PAG,3)
+6 WRITE !,"Sorted by",$$SRT(PSOSRT)
+7 WRITE !,"Date Range: "_$$DT(PSOSD+1\1)_" - "_$$DT(PSOED\1)
+8 WRITE ?48,"Run Date: "_$$FMTE^XLFDT($$NOW^XLFDT())
+9 SET X=""
SET $PIECE(X,"-",80)=""
WRITE !,X
+10 QUIT
+11 ;
SRT(ST) ; - Convert the "1,2,4" (example) to "PATIENT,ORDERABLE ITEM,STATUS"
+1 ;Input: ST-String with the Sorting fields by number
+2 ;Output: ST-String with the Sorting fields by name
+3 NEW I,X,STR,FLD
+4 SET STR="PATIENT NAME^ORDERABLE ITEM^DATE DOCUMENTED^STATUS^ORDER CHECKS"
+5 FOR I=1:1:$LENGTH(ST,",")
Begin DoDot:1
+6 SET FLD=+$PIECE(ST,",",I)
SET X=$PIECE(STR,"^",FLD)
+7 SET $PIECE(ST,",",I)=" "_X
End DoDot:1
+8 QUIT ST
+9 ;
DT(DT) ; - Convert FM Date to MM/DD/YYYY
+1 IF 'DT
QUIT ""
+2 IF '(DT#10000)
QUIT (1700+$EXTRACT(DT,1,3))
+3 IF '(DT#100)
QUIT $EXTRACT(DT,4,5)_"/"_(1700+$EXTRACT(DT,1,3))
+4 QUIT $EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_(1700+$EXTRACT(DT,1,3))
