PSONVAVW ;BHM/MFR - View Non-VA Med - Listmanager ;Mar 17, 2020@14:29:11
;;7.0;OUTPATIENT PHARMACY;**260,500,441**;DEC 1997;Build 208
;Reference to File ^PS(55 supported by DBIA 2228
;Reference to $$GET1^DIQ is supported by DBIA 2056
;Reference to DEM^VADPT is supported by DBIA 10061
;Reference to EN6^GMRVUTL is supported by DBIA 1120
;
EN(PSODFN,PSORD) ; - Entry point
N VALMCNT,VALMHDR
D EN^VALM("PSO NON-VA MEDS VIEW")
Q
;
HDR ; - Header
N LINE1,LINE2,LINE3,WT,WTDT,HT,HTDT,VADM,DFN,PNAME,DOB,SEX,X,VADM,WT,HT,GMRVST,GMRVSTR,DOB,PNAME,SEX
;
K VADM S DFN=PSODFN D DEM^VADPT
S PNAME=VADM(1)
S DOB=$S(+VADM(3):$P(VADM(3),"^",2)_" ("_$G(VADM(4))_")",1:"UNKNOWN")
S SEX=$P(VADM(5),"^",2)
S (WT,X)="",GMRVSTR="WT" D EN6^GMRVUTL I X'="" S WT=$J($P(X,"^",8)/2.2046226,6,2),WTDT=$$DT($P(X,"^")\1)
S (HT,X)="",GMRVSTR="HT" D EN6^GMRVUTL I X'="" S HT=$J($P(X,"^",8)*2.54,6,2),HTDT=$$DT($P(X,"^")\1)
S LINE1=PNAME S LINE1=$$ALLERGY^PSOPMP1(LINE1,DFN,"")
S LINE2=" PID: "_$P(VADM(2),"^",2),$E(LINE2,50)="HEIGHT(cm): "_$S(HT'="":HT_" ("_HTDT_")",1:"NOT AVAILABLE")
S LINE3=" DOB: "_DOB,$E(LINE3,30)="SEX: "_SEX,$E(LINE3,50)="WEIGHT(kg): "_$S(WT'="":WT_" ("_WTDT_")",1:"NOT AVAILABLE")
;
K VALMHDR S VALMHDR(1)=LINE1,VALMHDR(2)=LINE2,VALMHDR(3)=LINE3
;
Q
;
INIT ;
N OINAM,DGNAM,CLNAM,LINE,NMSPC,L,DIWL,DIWR,X,I,OCK,PRV,STR,TXT,K,TXT,XX
S XX=^PS(55,PSODFN,"NVA",PSORD,0),OINAM=$$GET1^DIQ(50.7,+$P(XX,"^"),.01)
S DGNAM="" I $P(XX,"^",2) S DGNAM=$$GET1^DIQ(50,+$P(XX,"^",2),.01)
;
S LINE=0,NMSPC="PSONVAVW" K ^TMP(NMSPC,$J)
S LINE=LINE+1,^TMP(NMSPC,$J,LINE,0)=$J("Non-VA Med: ",23)_OINAM
S LINE=LINE+1,^TMP(NMSPC,$J,LINE,0)=$J("Dispense Drug: ",23)_DGNAM
S LINE=LINE+1,^TMP(NMSPC,$J,LINE,0)=$J("Dosage: ",23)_$P(XX,"^",3)
;
K ^UTILITY($J,"W")
S X=$$SCHED^PSONVNEW($$GET1^DIQ(55.05,PSORD_","_PSODFN,4)),DIWL=1,DIWR=60 D ^DIWP
F L=1:1 Q:'$D(^UTILITY($J,"W",1,L)) D
. S X="" S:L=1 X=$J("Schedule: ",23) S $E(X,24)=^UTILITY($J,"W",1,L,0)
. S LINE=LINE+1,^TMP(NMSPC,$J,LINE,0)=X
;
S LINE=LINE+1,^TMP(NMSPC,$J,LINE,0)=$J("Med Route: ",23)_$P(XX,"^",4)
S LINE=LINE+1,^TMP(NMSPC,$J,LINE,0)=$J("Status: ",23)_$S('$P(XX,"^",6):"ACTIVE",1:"DISCONTINUED on "_$$DT($P(XX,"^",7)))
S LINE=LINE+1,^TMP(NMSPC,$J,LINE,0)=$J("CPRS Order #: ",23)_$P(XX,"^",8)
S LINE=LINE+1,^TMP(NMSPC,$J,LINE,0)=$J("Documented By: ",23)_$$GET1^DIQ(200,+$P(XX,"^",11),.01)
S LINE=LINE+1,^TMP(NMSPC,$J,LINE,0)=$J("Documented Date: ",23)_$$DT($P(XX,"^",10))
S CLNAM=$$GET1^DIQ(44,+$P(XX,"^",12),.01)
S LINE=LINE+1,^TMP(NMSPC,$J,LINE,0)=$J("Clinic: ",23)_$S($P(XX,"^",12):$P(XX,"^",12)_" - "_CLNAM,1:"")
S LINE=LINE+1,^TMP(NMSPC,$J,LINE,0)=$J("Start Date: ",23)_$$DT($P(XX,"^",9))
S LINE=LINE+1,^TMP(NMSPC,$J,LINE,0)=$J("Indication: ",23)_$P($G(^PS(55,PSODFN,"NVA",PSORD,2)),"^") ;*441-IND
;
; - "Order Checks" fields
W:$D(^PS(55,PSODFN,"NVA",PSORD,"OCK")) !
F I=0:0 S I=$O(^PS(55,PSODFN,"NVA",PSORD,"OCK",I)) Q:'I D
. S OCK=^PS(55,PSODFN,"NVA",PSORD,"OCK",I,0),STR=$P(OCK,"^"),PRV=+$P(OCK,"^",2)
. K TXT D TEXT(.TXT,STR,61)
. D STXT(" Order Check #"_I_": ",.TXT)
. K TXT
. F J=0:0 S J=$O(^PS(55,PSODFN,"NVA",PSORD,"OCK",I,"OVR",J)) Q:'J D
. . S STR=^PS(55,PSODFN,"NVA",PSORD,"OCK",I,"OVR",J,0)
. . D TEXT(.TXT,STR,57)
. D STXT(" Override Reason: ",.TXT)
. S LINE=LINE+1,^TMP(NMSPC,$J,LINE,0)=" Override Provider: "_$S(PRV:$$GET1^DIQ(200,+PRV,.01),1:"")
;
; - "Statement/Explanation" field
I $D(^PS(55,PSODFN,"NVA",PSORD,"DSC")) D
. K TXT
. F I=0:0 S I=$O(^PS(55,PSODFN,"NVA",PSORD,"DSC",I)) Q:'I D
. . S STR=^PS(55,PSODFN,"NVA",PSORD,"DSC",I,0)
. . D TEXT(.TXT,STR,57)
. D STXT("Statement/Explanation: ",.TXT)
;
; - "Comments" field
I $D(^PS(55,PSODFN,"NVA",PSORD,1)) D
. K TXT
. F I=0:0 S I=$O(^PS(55,PSODFN,"NVA",PSORD,1,I)) Q:'I D
. . S STR=^PS(55,PSODFN,"NVA",PSORD,1,I,0)
. . D TEXT(.TXT,STR,57)
. D STXT(" Comments: ",.TXT)
;
S VALMCNT=LINE
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
;
STXT(LABEL,TXT) ; Sets text lines
N K,X
F K=1:1 Q:'$D(TXT(K)) D
. S X="" S:K=1 X=LABEL S $E(X,24)=TXT(K)
. S LINE=LINE+1,^TMP(NMSPC,$J,LINE,0)=X
Q
;
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))
;
EXIT Q
;
HELP Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSONVAVW 4623 printed Dec 13, 2024@02:31:39 Page 2
PSONVAVW ;BHM/MFR - View Non-VA Med - Listmanager ;Mar 17, 2020@14:29:11
+1 ;;7.0;OUTPATIENT PHARMACY;**260,500,441**;DEC 1997;Build 208
+2 ;Reference to File ^PS(55 supported by DBIA 2228
+3 ;Reference to $$GET1^DIQ is supported by DBIA 2056
+4 ;Reference to DEM^VADPT is supported by DBIA 10061
+5 ;Reference to EN6^GMRVUTL is supported by DBIA 1120
+6 ;
EN(PSODFN,PSORD) ; - Entry point
+1 NEW VALMCNT,VALMHDR
+2 DO EN^VALM("PSO NON-VA MEDS VIEW")
+3 QUIT
+4 ;
HDR ; - Header
+1 NEW LINE1,LINE2,LINE3,WT,WTDT,HT,HTDT,VADM,DFN,PNAME,DOB,SEX,X,VADM,WT,HT,GMRVST,GMRVSTR,DOB,PNAME,SEX
+2 ;
+3 KILL VADM
SET DFN=PSODFN
DO DEM^VADPT
+4 SET PNAME=VADM(1)
+5 SET DOB=$SELECT(+VADM(3):$PIECE(VADM(3),"^",2)_" ("_$GET(VADM(4))_")",1:"UNKNOWN")
+6 SET SEX=$PIECE(VADM(5),"^",2)
+7 SET (WT,X)=""
SET GMRVSTR="WT"
DO EN6^GMRVUTL
IF X'=""
SET WT=$JUSTIFY($PIECE(X,"^",8)/2.2046226,6,2)
SET WTDT=$$DT($PIECE(X,"^")\1)
+8 SET (HT,X)=""
SET GMRVSTR="HT"
DO EN6^GMRVUTL
IF X'=""
SET HT=$JUSTIFY($PIECE(X,"^",8)*2.54,6,2)
SET HTDT=$$DT($PIECE(X,"^")\1)
+9 SET LINE1=PNAME
SET LINE1=$$ALLERGY^PSOPMP1(LINE1,DFN,"")
+10 SET LINE2=" PID: "_$PIECE(VADM(2),"^",2)
SET $EXTRACT(LINE2,50)="HEIGHT(cm): "_$SELECT(HT'="":HT_" ("_HTDT_")",1:"NOT AVAILABLE")
+11 SET LINE3=" DOB: "_DOB
SET $EXTRACT(LINE3,30)="SEX: "_SEX
SET $EXTRACT(LINE3,50)="WEIGHT(kg): "_$SELECT(WT'="":WT_" ("_WTDT_")",1:"NOT AVAILABLE")
+12 ;
+13 KILL VALMHDR
SET VALMHDR(1)=LINE1
SET VALMHDR(2)=LINE2
SET VALMHDR(3)=LINE3
+14 ;
+15 QUIT
+16 ;
INIT ;
+1 NEW OINAM,DGNAM,CLNAM,LINE,NMSPC,L,DIWL,DIWR,X,I,OCK,PRV,STR,TXT,K,TXT,XX
+2 SET XX=^PS(55,PSODFN,"NVA",PSORD,0)
SET OINAM=$$GET1^DIQ(50.7,+$PIECE(XX,"^"),.01)
+3 SET DGNAM=""
IF $PIECE(XX,"^",2)
SET DGNAM=$$GET1^DIQ(50,+$PIECE(XX,"^",2),.01)
+4 ;
+5 SET LINE=0
SET NMSPC="PSONVAVW"
KILL ^TMP(NMSPC,$JOB)
+6 SET LINE=LINE+1
SET ^TMP(NMSPC,$JOB,LINE,0)=$JUSTIFY("Non-VA Med: ",23)_OINAM
+7 SET LINE=LINE+1
SET ^TMP(NMSPC,$JOB,LINE,0)=$JUSTIFY("Dispense Drug: ",23)_DGNAM
+8 SET LINE=LINE+1
SET ^TMP(NMSPC,$JOB,LINE,0)=$JUSTIFY("Dosage: ",23)_$PIECE(XX,"^",3)
+9 ;
+10 KILL ^UTILITY($JOB,"W")
+11 SET X=$$SCHED^PSONVNEW($$GET1^DIQ(55.05,PSORD_","_PSODFN,4))
SET DIWL=1
SET DIWR=60
DO ^DIWP
+12 FOR L=1:1
if '$DATA(^UTILITY($JOB,"W",1,L))
QUIT
Begin DoDot:1
+13 SET X=""
if L=1
SET X=$JUSTIFY("Schedule: ",23)
SET $EXTRACT(X,24)=^UTILITY($JOB,"W",1,L,0)
+14 SET LINE=LINE+1
SET ^TMP(NMSPC,$JOB,LINE,0)=X
End DoDot:1
+15 ;
+16 SET LINE=LINE+1
SET ^TMP(NMSPC,$JOB,LINE,0)=$JUSTIFY("Med Route: ",23)_$PIECE(XX,"^",4)
+17 SET LINE=LINE+1
SET ^TMP(NMSPC,$JOB,LINE,0)=$JUSTIFY("Status: ",23)_$SELECT('$PIECE(XX,"^",6):"ACTIVE",1:"DISCONTINUED on "_$$DT($PIECE(XX,"^",7)))
+18 SET LINE=LINE+1
SET ^TMP(NMSPC,$JOB,LINE,0)=$JUSTIFY("CPRS Order #: ",23)_$PIECE(XX,"^",8)
+19 SET LINE=LINE+1
SET ^TMP(NMSPC,$JOB,LINE,0)=$JUSTIFY("Documented By: ",23)_$$GET1^DIQ(200,+$PIECE(XX,"^",11),.01)
+20 SET LINE=LINE+1
SET ^TMP(NMSPC,$JOB,LINE,0)=$JUSTIFY("Documented Date: ",23)_$$DT($PIECE(XX,"^",10))
+21 SET CLNAM=$$GET1^DIQ(44,+$PIECE(XX,"^",12),.01)
+22 SET LINE=LINE+1
SET ^TMP(NMSPC,$JOB,LINE,0)=$JUSTIFY("Clinic: ",23)_$SELECT($PIECE(XX,"^",12):$PIECE(XX,"^",12)_" - "_CLNAM,1:"")
+23 SET LINE=LINE+1
SET ^TMP(NMSPC,$JOB,LINE,0)=$JUSTIFY("Start Date: ",23)_$$DT($PIECE(XX,"^",9))
+24 ;*441-IND
SET LINE=LINE+1
SET ^TMP(NMSPC,$JOB,LINE,0)=$JUSTIFY("Indication: ",23)_$PIECE($GET(^PS(55,PSODFN,"NVA",PSORD,2)),"^")
+25 ;
+26 ; - "Order Checks" fields
+27 if $DATA(^PS(55,PSODFN,"NVA",PSORD,"OCK"))
WRITE !
+28 FOR I=0:0
SET I=$ORDER(^PS(55,PSODFN,"NVA",PSORD,"OCK",I))
if 'I
QUIT
Begin DoDot:1
+29 SET OCK=^PS(55,PSODFN,"NVA",PSORD,"OCK",I,0)
SET STR=$PIECE(OCK,"^")
SET PRV=+$PIECE(OCK,"^",2)
+30 KILL TXT
DO TEXT(.TXT,STR,61)
+31 DO STXT(" Order Check #"_I_": ",.TXT)
+32 KILL TXT
+33 FOR J=0:0
SET J=$ORDER(^PS(55,PSODFN,"NVA",PSORD,"OCK",I,"OVR",J))
if 'J
QUIT
Begin DoDot:2
+34 SET STR=^PS(55,PSODFN,"NVA",PSORD,"OCK",I,"OVR",J,0)
+35 DO TEXT(.TXT,STR,57)
End DoDot:2
+36 DO STXT(" Override Reason: ",.TXT)
+37 SET LINE=LINE+1
SET ^TMP(NMSPC,$JOB,LINE,0)=" Override Provider: "_$SELECT(PRV:$$GET1^DIQ(200,+PRV,.01),1:"")
End DoDot:1
+38 ;
+39 ; - "Statement/Explanation" field
+40 IF $DATA(^PS(55,PSODFN,"NVA",PSORD,"DSC"))
Begin DoDot:1
+41 KILL TXT
+42 FOR I=0:0
SET I=$ORDER(^PS(55,PSODFN,"NVA",PSORD,"DSC",I))
if 'I
QUIT
Begin DoDot:2
+43 SET STR=^PS(55,PSODFN,"NVA",PSORD,"DSC",I,0)
+44 DO TEXT(.TXT,STR,57)
End DoDot:2
+45 DO STXT("Statement/Explanation: ",.TXT)
End DoDot:1
+46 ;
+47 ; - "Comments" field
+48 IF $DATA(^PS(55,PSODFN,"NVA",PSORD,1))
Begin DoDot:1
+49 KILL TXT
+50 FOR I=0:0
SET I=$ORDER(^PS(55,PSODFN,"NVA",PSORD,1,I))
if 'I
QUIT
Begin DoDot:2
+51 SET STR=^PS(55,PSODFN,"NVA",PSORD,1,I,0)
+52 DO TEXT(.TXT,STR,57)
End DoDot:2
+53 DO STXT(" Comments: ",.TXT)
End DoDot:1
+54 ;
+55 SET VALMCNT=LINE
+56 QUIT
+57 ;
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 ;
STXT(LABEL,TXT) ; Sets text lines
+1 NEW K,X
+2 FOR K=1:1
if '$DATA(TXT(K))
QUIT
Begin DoDot:1
+3 SET X=""
if K=1
SET X=LABEL
SET $EXTRACT(X,24)=TXT(K)
+4 SET LINE=LINE+1
SET ^TMP(NMSPC,$JOB,LINE,0)=X
End DoDot:1
+5 QUIT
+6 ;
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))
+5 ;
EXIT QUIT
+1 ;
HELP QUIT
