- PSONVAVW ;BHM/MFR - View Non-VA Med - Listmanager ;10/20/06
- ;;7.0;OUTPATIENT PHARMACY;**260**;13 Feb 97;Build 84
- ;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.2,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))
- ;
- ; - "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
- PSONVAVW ;BHM/MFR - View Non-VA Med - Listmanager ;10/20/06
- +1 ;;7.0;OUTPATIENT PHARMACY;**260**;13 Feb 97;Build 84
- +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.2,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 ;
- +25 ; - "Order Checks" fields
- +26 IF $DATA(^PS(55,PSODFN,"NVA",PSORD,"OCK"))
- WRITE !
- +27 FOR I=0:0
- SET I=$ORDER(^PS(55,PSODFN,"NVA",PSORD,"OCK",I))
- IF 'I
- QUIT
- Begin DoDot:1
- +28 SET OCK=^PS(55,PSODFN,"NVA",PSORD,"OCK",I,0)
- SET STR=$PIECE(OCK,"^")
- SET PRV=+$PIECE(OCK,"^",2)
- +29 KILL TXT
- DO TEXT(.TXT,STR,61)
- +30 DO STXT(" Order Check #"_I_": ",.TXT)
- +31 KILL TXT
- +32 FOR J=0:0
- SET J=$ORDER(^PS(55,PSODFN,"NVA",PSORD,"OCK",I,"OVR",J))
- IF 'J
- QUIT
- Begin DoDot:2
- +33 SET STR=^PS(55,PSODFN,"NVA",PSORD,"OCK",I,"OVR",J,0)
- +34 DO TEXT(.TXT,STR,57)
- End DoDot:2
- +35 DO STXT(" Override Reason: ",.TXT)
- +36 SET LINE=LINE+1
- SET ^TMP(NMSPC,$JOB,LINE,0)=" Override Provider: "_$SELECT(PRV:$$GET1^DIQ(200,+PRV,.01),1:"")
- End DoDot:1
- +37 ;
- +38 ; - "Statement/Explanation" field
- +39 IF $DATA(^PS(55,PSODFN,"NVA",PSORD,"DSC"))
- Begin DoDot:1
- +40 KILL TXT
- +41 FOR I=0:0
- SET I=$ORDER(^PS(55,PSODFN,"NVA",PSORD,"DSC",I))
- IF 'I
- QUIT
- Begin DoDot:2
- +42 SET STR=^PS(55,PSODFN,"NVA",PSORD,"DSC",I,0)
- +43 DO TEXT(.TXT,STR,57)
- End DoDot:2
- +44 DO STXT("Statement/Explanation: ",.TXT)
- End DoDot:1
- +45 ;
- +46 ; - "Comments" field
- +47 IF $DATA(^PS(55,PSODFN,"NVA",PSORD,1))
- Begin DoDot:1
- +48 KILL TXT
- +49 FOR I=0:0
- SET I=$ORDER(^PS(55,PSODFN,"NVA",PSORD,1,I))
- IF 'I
- QUIT
- Begin DoDot:2
- +50 SET STR=^PS(55,PSODFN,"NVA",PSORD,1,I,0)
- +51 DO TEXT(.TXT,STR,57)
- End DoDot:2
- +52 DO STXT(" Comments: ",.TXT)
- End DoDot:1
- +53 ;
- +54 SET VALMCNT=LINE
- +55 QUIT
- +56 ;
- 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
