Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSONVAR1

PSONVAR1.m

Go to the documentation of this file.
  1. 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
  1. ;External reference to File ^PS(55 supported by DBIA 2228
  1. ;External reference to $$GET1^DIQ is supported by DBIA 2056
  1. ;External reference to ^VADPT is supported by DBIA 10061
  1. ;External reference to ^XLFDT is supported by DBIA 10103
  1. ;External reference to ^%ZISC is supported by DBIA 10089
  1. ;
  1. ;Add complex orders to NVA Meds
  1. ;
  1. EN N DATE,DFN,ORD,PAG,PCNT,PRTD,OINAM,PNAM,I,J,Y,X,C,XX,S1,S2,S3,S4,S5,OCNT
  1. N OCK,OK,STS,SUB,SP1,SP2,SPF
  1. ;
  1. U IO K ^TMP("PSONV",$J),^TMP("PSOCNT",$J)
  1. S SPF=0,(SP1,SP2)="",$P(SP1,"=",80)="",$P(SP2,"-",80)=""
  1. ;
  1. ; - Loop through the Non-VA Med orders x-reference
  1. S DATE=PSOSD,(DFN,ORD)="",(PCNT,OCNT,PRTD)=0 K DIRUT
  1. DATE S DATE=$O(^PS(55,"ADCDT",DATE)) G NEXT:DATE=""!(DATE>PSOED)
  1. W:SPF SP1
  1. ;
  1. DFN I PSOAPT S DFN=$O(^PS(55,"ADCDT",DATE,DFN)) G DATE:DFN=""
  1. I 'PSOAPT S DFN=$O(PSOPT(DFN)) G DATE:DFN="" ;Patient Filter
  1. ;
  1. I $$DEAD^PSONVARP(DFN) G DFN ;Patient is Dead
  1. ;
  1. ORD S ORD=$O(^PS(55,"ADCDT",DATE,DFN,ORD)) G DFN:ORD=""
  1. S XX=$G(^PS(55,DFN,"NVA",ORD,0))
  1. I 'PSOAOI,'$D(PSOOI(+$P(XX,"^"))) G ORD ;OI Filter
  1. I '$P(XX,"^",6),PSOST="D" G ORD ;Status Filter
  1. I $P(XX,"^",6),PSOST="A" G ORD
  1. I '$D(^PS(55,DFN,"NVA",ORD,"OCK")),PSOOC="Y" G ORD ;Order Checks Filter
  1. I $D(^PS(55,DFN,"NVA",ORD,"OCK")),PSOOC="N" G ORD
  1. ;
  1. I PSOSRT=3 D G CLOSE:$D(DIRUT),ORD ;If not Sorting,
  1. . I $Y>(IOSL-9) D HDR I $D(DIRUT) Q ;Print the Report
  1. . D PRINT(DFN,ORD) Q:$D(DIRUT) S SPF=1 ;Then G ORD
  1. ;
  1. I PSOSRT[1 S PNAM=$$GET1^DIQ(2,DFN,.01) ;Retrieving Patient
  1. I PSOSRT[2 S OINAM=$$GET1^DIQ(50.7,+$P(XX,"^"),.01) ;Name and Orderable
  1. S:$G(PNAM)="" PNAM=0 S:$G(OINAM)="" OINAM=0 ;Item Name
  1. S (S1,S2,S3,S4,S5)=0
  1. F I=1:1:$L(PSOSRT,",") D
  1. . S Y=$P(PSOSRT,",",I),STS=+$P(XX,"^",6)
  1. . S OCK=$S($D(^PS(55,DFN,"NVA",ORD,"OCK")):1,1:2)
  1. . S @("S"_I)=$S(Y=1:PNAM,Y=2:OINAM,Y=3:DATE,Y=4:+STS,Y=5:OCK)
  1. S ^TMP("PSONV",$J,S1,S2,S3,S4,S5,DFN,ORD)=""
  1. G ORD
  1. ;
  1. NEXT ; - If not Sorting (already printed), SKIP, otherwise, print the report
  1. I PSOSRT="" G NDTP
  1. S (S1,S2,S3,S4,S5,DFN,ORD)=""
  1. F S S1=$O(^TMP("PSONV",$J,S1)) Q:S1="" D Q:$D(DIRUT)
  1. . F S S2=$O(^TMP("PSONV",$J,S1,S2)) Q:S2="" D Q:$D(DIRUT)
  1. . . F S S3=$O(^TMP("PSONV",$J,S1,S2,S3)) Q:S3="" D Q:$D(DIRUT)
  1. . . . F S S4=$O(^TMP("PSONV",$J,S1,S2,S3,S4)) Q:S4="" D Q:$D(DIRUT)
  1. . . . . F S S5=$O(^TMP("PSONV",$J,S1,S2,S3,S4,S5)) Q:S5="" D Q:$D(DIRUT)
  1. . . . . . F S DFN=$O(^TMP("PSONV",$J,S1,S2,S3,S4,S5,DFN)) Q:DFN="" D Q:$D(DIRUT)
  1. . . . . . . F S ORD=$O(^TMP("PSONV",$J,S1,S2,S3,S4,S5,DFN,ORD)) Q:ORD="" D Q:$D(DIRUT)
  1. . . . . . . . I $Y>(IOSL-12) D HDR I $D(DIRUT) Q
  1. . . . . . . . D PRINT(DFN,ORD)
  1. . . I '$D(DIRUT),S2'=0,$O(^TMP("PSONV",$J,S1,S2))'="" W SP2
  1. . I '$D(DIRUT),$O(^TMP("PSONV",$J,S1))'="" W SP1
  1. G CLOSE:$D(DIRUT)
  1. ;
  1. NDTP I 'PRTD D HDR W !!?18,"********** NO DATA TO PRINT **********"
  1. I PRTD D
  1. . W SP1
  1. . W !,"Total: ",PCNT," patient",$S(PCNT>1:"s",1:"")
  1. . W " and ",OCNT," order",$S(OCNT>1:"s",1:""),"."
  1. . D HDR Q:$D(DIRUT) ;pause for reading of total before scrolls away...
  1. ;
  1. CLOSE D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
  1. END K ^TMP("PSONV",$J),^TMP("PSOCNT",$J)
  1. Q
  1. ;
  1. PRINT(DFN,ORD) ; - Print a Non-VA Med Order
  1. ;Input: DFN-Patient;ORD-Non-VA Order#
  1. N X,XX,K,OI,OIX,OINAM,DGNAM,PNAM,PSSN,CLNAM,PRV,I,J,Z,TXT,VAPA,VADM,SCH
  1. N STR,OCK
  1. ;
  1. I '$D(^PS(55,DFN,"NVA",ORD)) Q
  1. I '$G(PAG) D HDR I $D(DIRUT) Q
  1. ;
  1. S XX=^PS(55,DFN,"NVA",ORD,0),OINAM=$$GET1^DIQ(50.7,+$P(XX,"^"),.01)
  1. S DGNAM="" I $P(XX,"^",2) S DGNAM=$$GET1^DIQ(50,+$P(XX,"^",2),.01)
  1. D DEM^VADPT,ADD^VADPT S PNAM=$P(VADM(1),"^"),PSSN=$P($G(VADM(2)),"^",2)
  1. W !,PNAM," (ID:",$S(PSSN:$P(PSSN,"-",3),1:"0000"),")"
  1. W ?46,"Patient Phone #: ",$E($P(VAPA(8),"^"),1,16)
  1. S:'$D(^TMP("PSOCNT",$J,DFN)) PCNT=PCNT+1 S ^TMP("PSOCNT",$J,DFN)=""
  1. ;
  1. W !?5,"Non-VA Med: ",OINAM
  1. D PRTDDR ;print dispense drug line(s)
  1. W !?9,"Status: ",$S('$P(XX,"^",6):"ACTIVE",1:"DISCONTINUED on "_$$DT($P(XX,"^",7)))
  1. W ?49,"CPRS Order #: ",$P(XX,"^",8)
  1. W !?2,"Documented By: ",$E($$GET1^DIQ(200,+$P(XX,"^",11),.01),1,29)
  1. W ?46,"Documented Date: ",$$DT($P(XX,"^",10))
  1. S CLNAM=$$GET1^DIQ(44,+$P(XX,"^",12),.01)
  1. W !?9,"Clinic: " W:$P(XX,"^",12) $E($P(XX,"^",12)_" - "_CLNAM,1,33)
  1. W ?51,"Start Date: ",$$DT($P(XX,"^",9)),!
  1. W ?5,"Indication: ",$P($G(^PS(55,DFN,"NVA",ORD,2)),"^"),! ;*441-IND
  1. I $Y>(IOSL-4) D HDR Q:$D(DIRUT) W !
  1. ;
  1. ; - Printing "Order Checks" fields
  1. W:$D(^PS(55,DFN,"NVA",ORD,"OCK")) !
  1. F I=0:0 S I=$O(^PS(55,DFN,"NVA",ORD,"OCK",I)) Q:'I D Q:$D(DIRUT)
  1. . S OCK=^PS(55,DFN,"NVA",ORD,"OCK",I,0),STR=$P(OCK,"^"),PRV=+$P(OCK,"^",2)
  1. . I $Y>(IOSL-5) D HDR Q:$D(DIRUT) W !
  1. . W ?1,"Order Check #",I,": " K TXT D TEXT(.TXT,STR,61)
  1. . F K=1:1 Q:'$D(TXT(K)) D Q:$D(DIRUT)
  1. . . W ?17,TXT(K),! I $Y>(IOSL-4) D HDR Q:$D(DIRUT) W !
  1. . Q:$D(DIRUT) K TXT
  1. . F J=0:0 S J=$O(^PS(55,DFN,"NVA",ORD,"OCK",I,"OVR",J)) Q:'J D
  1. . . S STR=^PS(55,DFN,"NVA",ORD,"OCK",I,"OVR",J,0)
  1. . . D TEXT(.TXT,STR,56)
  1. . W ?6,"Override Reason: " W:'$D(TXT) !
  1. . F K=1:1 Q:'$D(TXT(K)) D Q:$D(DIRUT)
  1. . . W ?23,TXT(K),! I $Y>(IOSL-4) D HDR Q:$D(DIRUT) W !
  1. . Q:$D(DIRUT)
  1. . W ?6,"Override Provider: " W:PRV $$GET1^DIQ(200,+PRV,.01) W !
  1. Q:$D(DIRUT)
  1. ;
  1. ; - Printing "Statement/Explanation/Comments" field
  1. I $D(^PS(55,DFN,"NVA",ORD,"DSC")) D Q:$D(DIRUT)
  1. . W !,"Statement/Explanation/Comments: " K TXT
  1. . F I=0:0 S I=$O(^PS(55,DFN,"NVA",ORD,"DSC",I)) Q:'I D
  1. . . S STR=^PS(55,DFN,"NVA",ORD,"DSC",I,0)
  1. . . D TEXT(.TXT,STR,47)
  1. . F K=1:1 Q:'$D(TXT(K)) D Q:$D(DIRUT)
  1. . . W ?32,TXT(K),! I $Y>(IOSL-4) D HDR Q:$D(DIRUT) W !
  1. ;
  1. S PRTD=1,OCNT=OCNT+1
  1. Q
  1. ;
  1. 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,
  1. ; if OLD recorsd found, i.e. no new 55.516 multiple, then use OLD print method for backwards compatibility
  1. N DDR,DDX,DDR05,DDR15,REC,SCHX,SCHY
  1. S REC=$S($O(^PS(55,DFN,"NVA",ORD,3,0)):"NEW",1:"OLD") ;NEW multiple found or Not, OLD
  1. ;Rec=OLD - Data Dic orders created pre *441 version, backwards compatibility
  1. I REC="OLD" D Q
  1. . W !?2,"Dispense Drug: ",$E(DGNAM,1,37)
  1. . W ?55,"Dosage: ",$E($P(XX,"^",3),1,16)
  1. . W !?7,"Schedule: " S X=$E($P(XX,"^",5),1,30)
  1. . S SCH=$S($L($P(XX,"^",5))>30:$P(X," ",1,$L(X," ")-1),1:X) W SCH
  1. . W ?52,"Med Route: ",$E($P(XX,"^",4),1,35)
  1. . I $E($P(XX,"^",5),$L(SCH)+1,99)'="" D
  1. . . W !?16,$E($P(XX,"^",5),$L(SCH)+1,99)
  1. ;Rec=NEW -Data Dic orders created post
  1. S DDR=0
  1. F S DDR=$O(^PS(55,DFN,"NVA",ORD,3,DDR)) Q:'DDR D
  1. . S DDR05=ORD_","_DFN,DDR15=DDR_","_DDR05
  1. . S DGNAM="",DDX=+$$GET1^DIQ(55.05,DDR05,"DISPENSE DRUG","I") S:DDX DGNAM=$$GET1^DIQ(50,DDX,.01)
  1. . 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 !
  1. . 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)
  1. . 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 !
  1. . I $E(SCHX,$L(SCH)+1,99)'="" D
  1. . . W !?16,$E(SCHX,$L(SCH)+1,99) I $Y>(IOSL-4) D HDR Q:$D(DIRUT) W !
  1. . ;add below 2 new fields to report
  1. . W !?7,"Duration: ",$E($$GET1^DIQ(55.516,DDR15,"DURATION"),1,37),?50,"Conjunction: ",$E($$GET1^DIQ(55.516,DDR15,"CONJUNCTION"),1,16)
  1. . I $Y>(IOSL-4) D HDR Q:$D(DIRUT) W !
  1. Q
  1. ;
  1. TEXT(TEXT,STR,L) ; Formats STR into TEXT array, lines lenght = L
  1. N J,WORD,K S K=+$O(TEXT(""),-1) S:'K K=1
  1. F J=1:1:$L(STR," ") D
  1. . S WORD=$P(STR," ",J) I ($L($G(TEXT(K))_WORD))>L S K=K+1
  1. . S TEXT(K)=$G(TEXT(K))_WORD_" "
  1. Q
  1. ;
  1. HDR ; - Prints the Header
  1. N X,DIR S PAG=$G(PAG)+1
  1. I PAG>1,$E(IOST)="C" D Q:$D(DIRUT)
  1. . S DIR(0)="E",DIR("A")=" Press ENTER to Continue or ^ to Exit" D ^DIR
  1. ;
  1. W @IOF,"Non-VA Meds Usage Report",?70,"Page: ",$J(PAG,3)
  1. W !,"Sorted by",$$SRT(PSOSRT)
  1. W !,"Date Range: "_$$DT(PSOSD+1\1)_" - "_$$DT(PSOED\1)
  1. W ?48,"Run Date: "_$$FMTE^XLFDT($$NOW^XLFDT())
  1. S X="",$P(X,"-",80)="" W !,X
  1. Q
  1. ;
  1. SRT(ST) ; - Convert the "1,2,4" (example) to "PATIENT,ORDERABLE ITEM,STATUS"
  1. ;Input: ST-String with the Sorting fields by number
  1. ;Output: ST-String with the Sorting fields by name
  1. N I,X,STR,FLD
  1. S STR="PATIENT NAME^ORDERABLE ITEM^DATE DOCUMENTED^STATUS^ORDER CHECKS"
  1. F I=1:1:$L(ST,",") D
  1. . S FLD=+$P(ST,",",I),X=$P(STR,"^",FLD)
  1. . S $P(ST,",",I)=" "_X
  1. Q ST
  1. ;
  1. DT(DT) ; - Convert FM Date to MM/DD/YYYY
  1. I 'DT Q ""
  1. I '(DT#10000) Q (1700+$E(DT,1,3))
  1. I '(DT#100) Q $E(DT,4,5)_"/"_(1700+$E(DT,1,3))
  1. Q $E(DT,4,5)_"/"_$E(DT,6,7)_"/"_(1700+$E(DT,1,3))