- 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 Feb 18, 2025@23:58:02 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))