GMTSPSHO ; SLC OIFO/GS - Herbal/OTC Medications Health Summary; 01/26/2004
;;2.7;Health Summary;**65**;Oct 20, 1995
;v6;04/07/2004
;
; External References
; DBIA 330 ^PSOHCSUM which includes ^TMP("PSOO",$J)
; DBIA 10003 DD^%DT
; DBIA 10035 ^DPT( file #2
; DBAI 10060 ^VA(200
;
; Format of ^TMP("PS00",$J,"NVA",ILFD,0) as G1 aka GMRC
; (see also ^PSOHCSUM):
;
; Field Descriptions Defined AKA/Notes
; Orderable Item $P(G1,U) Includes dosage form
; (File # 50.7)
; Status $P(G1,U,2)
; Discontinued Date $P(G1,U,7) FM format
; Order # $P(G1,U,4) CPRS Order # ptr to
; File #100
; Documented By $P($P(G1,U,6),";",2) Doc. by Name ptr to
; File #200 is $P(x;1)
; Documented Date $P(G1,U,5) FM format (Entered On)
; Clinic $P($P(G2,U,5),";",2) Clinic Name ptr to
; File #44 is $P(x;1)
; Date Started $P(G1,U,3) FM format (Start Date)
; Drug $P($P(G2,U,4),";",2) Drug name (Dispensed)
; ptr to f#50 is $P(x;1)
; Dosage $P(G2,U)
; Medication Route $P(G2,U,2)
; Schedule $P(G2,U,3)
; Statement/Explanation ^TMP("PSOO",$J,"NVA",ILFD,"DSC",nn,0)
;
; where G1=^TMP("PSOO",$J,"NVA",ILFD,0)
; G2=^TMP("PSOO",$J,"NVA",ILFD,1,0)
; nn & nnn = sequentual integers
;
; Variables Descriptions
; CT Counter of number of Herbal/OTC/Non-VA drugs for patient
; DFN Patient internal number passed in
; DGR Documented by's degree
; ILFD Inverse Last Fill Date (FM format)
; JOB $J
; G1,G2 Abstracted data strings from ^TMP("PSOO", - see MAIN & WRT
; GMT* Variables used by HS pagination routine (GMTSUP), e.g.,
; GMTSLPG=last page, GMTSTITL=title
; LL* Line lengths ('^' delimited) for override reason & S/E
; NEWFORM ;
; NL Sequential line counter for override reasons &
; statement/explanation
; T1,T2,T3 Integer tab stops for data display - see MAIN
; T4 Tab stops (#,#) for override reason display
; T5 Tab stops for Stmt/Expln display
; V Line header verbiage describing data displayed
; VARY Array of verbiage to be displayed (override reason & S/E)
; Y Scratch system variable
;
; Global Variables (variables defined outside this routine)
; DFN, GMTSNPG, GMTSQIT
;
MAIN ; Herbal/Over-the-Counter/Non-VA Medications
N CHAW,CLL,CT,DGR,G1,G2,GMTOP,GMX,I,ILFD,ILN,JOB,LINE,LL
N LL5,LP,MAX,NL,OLN,PLN,T1,T2,T3,T4,T5,V,VARY,VO,X,Y
S ILFD=0,JOB=$J,LL5="40^65"
S T1=16,T2=58,T3=33,T4="25,10",T5="33,10"
; Set variables for use by report pagination routine (GMTSUP)
S CT=0,MAX=999,GMX=0
; Check to see if a patient IEN is defined
I DFN="" D CKFORM W !?8,"No patient selected" Q
; Check page line count and print new page and header if necessary
D CKFORM Q:$D(GMTSQIT)
; Output header for report
D:GMTSNPG!(GMX'>0) HDR Q:$D(GMTSQIT) D CKFORM Q:$D(GMTSQIT)
W:'GMTOP ! S GMTOP=0,GMX=1
; Run Pharmacy extraction
D ^PSOHCSUM ; DBIA 330
; Quit if no herbals/non-VA drugs extracted - ^TMP("PSOO") via DBIA 330
I '$D(^TMP("PSOO",JOB,"NVA")) D CKFORM W !,?8,"No Non-VA Meds Extracted" Q
; Loop through ^TMP global array created by ^PSOHCSUM ; DBIA 330
; Quit if 1 Inverse Last Fill Date =0
; 2 Counter is not less than Max Occurrence
; 3 User has "up-arrowed" out of the display
F S ILFD=$O(^TMP("PSOO",JOB,"NVA",ILFD)) Q:+ILFD=0!(CT'<MAX)!($D(GMTSQIT)) D
. S G1=^TMP("PSOO",JOB,"NVA",ILFD,0)
. S G2=^TMP("PSOO",JOB,"NVA",ILFD,1,0),CT=CT+1
. D WRT
K ^TMP("PSOO",$J) ;delete temporary file created via PSOHCSUM
Q
;
WRT ; Write Data
D CKFORM Q:$D(GMTSQIT) ;line/pagination check - repeated ad nauseum
D:GMTSNPG!(GMX'>0) HDR Q:$D(GMTSQIT)
D CKFORM Q:$D(GMTSQIT)
S V="Non-VA Med: " W !?T1-$L(V),V,$P(G1,U)
D CKFORM Q:$D(GMTSQIT)
S V="Status: " W !?T1-$L(V),V,$P(G1,U,2)
; Display discontinued date if it exists (assume discontinued status)
S Y=$P(G1,U,7) I Y D DD^%DT W " (",$P(Y,"@"),")" ; DBIA 10003
S V="CPRS Order #: " W ?T2-$L(V),V,$P(G1,U,4)
D CKFORM Q:$D(GMTSQIT)
S V="Documented By: " W !?T1-$L(V),V,$P($P(G1,U,6),";",2)
I $P($P(G1,U,6),";") D DEGREE W:DGR'="" ",",DGR
S V="Documented Date: ",Y=$P(G1,U,5) D DD^%DT W ?T2-$L(V),V,Y ; DBIA 10003
D CKFORM Q:$D(GMTSQIT)
S V="Clinic: "
W !?T1-$L(V),V,$P($P(G2,U,5),";"),"-",$P($P(G2,U,5),";",2)
S V="Start Date: ",Y=$P(G1,U,3) D DD^%DT W ?T2-$L(V),V,Y ; DBIA 10003
D CKFORM Q:$D(GMTSQIT)
S V="Dispense Drug: " W !?T1-$L(V),V,$P($P(G2,U,4),";",2)
S V="Dosage: " W ?T2-$L(V),V,$P(G2,U)
D CKFORM Q:$D(GMTSQIT)
S V="Med Route: " W !?T1-$L(V),V,$P(G2,U,2)
S V="Schedule: " W ?T2-$L(V),V,$P(G2,U,3)
S V="Statement/Explanation/Comment: ",NL=""
D CKFORM Q:$D(GMTSQIT)
W !
D CKFORM Q:$D(GMTSQIT)
W !?T3-$L(V),V
K V M V=^TMP("PSOO",JOB,"NVA",ILFD,"DSC")
; Statement/Explanation verbiage
D LINES(LL5,.V) K V D LINESOUT(T5)
D CKFORM W !
K VO,X,Y
Q
;
LINESOUT(TN) ;WRITE LINES
F S NL=$O(VO(NL)) Q:NL=""!$D(GMTSQIT) D
. I NL=1 W ?$P(TN,","),VO(NL)
. E D CKFORM Q:$D(GMTSQIT) W !?$P(T4,",",2),VO(NL)
Q
;
LINES(LL,V) ;BREAK LINES OF AN ARRAY INTO APPROPRIATE MAX LENGTHS
;
; Input:
; LL = line lengths, e.g., 20^30^40 where last remains default
; V = input array w/ no null lines, use " " for blank line
;
;Output:
; OV = output array of lines broken into specified maximum lengths
;
; This subroutine takes an array of text (V) and breaks the text into
; line lengths as dictated via LL. Where the first line length (max)
; of the resulting array (VO) will be (approximately, based on line
; contents) $P(LL,"^",1), the second line length (max) will be
; $P(LL,"^",2), etc. The last line length in LL becomes the default
; maximum line length for all the remaining lines.
;
; This subroutine is useful if you want lines output in different
; lengths.
;
; Variables used:
; CHAW = the next piece of a line of a maximum byte length
; CLL = current line length (max)
; I = scratch variable
; ILN = input array line number
; LP = pointer indicating where in a line the last chaw taken
; OLN = output (resulting) line number
; PLN = previous line length (max)
; X = line being parsed for a breaking point
;
N CHAW,CLL,ILN,LP,OLN,PLN
K VO
S (I,ILN,X)="",OLN=1,CLL=$P(LL,U,OLN),PLN=CLL
F S ILN=$O(V(ILN)) Q:ILN="" S LP=1 D
. S I=$E($RE(V(ILN,0)))
. S V(ILN,0)=V(ILN,0)_$S("!?."[I:" ",",;:"[I!(I?1A):" ",1:"")
. I V(ILN,0)=" " S:X'="" VO(OLN)=X,X="",OLN=OLN+1 S VO(OLN)=" ",OLN=OLN+1 Q
. F S CHAW=$E(V(ILN,0),LP,LP+CLL-$L(X)),LP=LP+$L(CHAW),X=X_CHAW Q:CHAW=""!($L(X)<CLL) D
.. I $L(X)<CLL S VO(OLN)=X,X="" D LINESET Q
.. I X'[" "&($L(X)=CLL) S VO(OLN)=X_"-",X="" D LINESET Q
.. F I=$L(X):-1:1 Q:$E(X,I)=" "!($E(X,I)="-")
.. S VO(OLN)=$E(X,1,I),X=$E(X,I+1,999) D LINESET
S:X'="" VO(OLN)=X
Q
;
LINESET ; Used by LINES for setting variables
S OLN=OLN+1,PLN=CLL,CLL=$P(LL,U,OLN) S:+CLL=0 CLL=PLN
Q
;
CKFORM ; Checks to determine whether to do a form feed or not
D CKP^GMTSUP Q:$D(GMTSQIT)
Q
;
HDR ; Prints Header
S GMTOP=1
I GMX'>0 D CKP^GMTSUP Q:$D(GMTSQIT)
I 'GMTSNPG D CKP^GMTSUP Q:$D(GMTSQIT)
Q
;
DEGREE ; Gets degree of 'Documented by' individual & converts to upper case
S DGR=$$GET1^DIQ(200,$P($P(G1,U,6),";"),10.6) ; DBIA 10060
S DGR=$TR(DGR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSPSHO 8257 printed Sep 23, 2025@19:35:36 Page 2
GMTSPSHO ; SLC OIFO/GS - Herbal/OTC Medications Health Summary; 01/26/2004
+1 ;;2.7;Health Summary;**65**;Oct 20, 1995
+2 ;v6;04/07/2004
+3 ;
+4 ; External References
+5 ; DBIA 330 ^PSOHCSUM which includes ^TMP("PSOO",$J)
+6 ; DBIA 10003 DD^%DT
+7 ; DBIA 10035 ^DPT( file #2
+8 ; DBAI 10060 ^VA(200
+9 ;
+10 ; Format of ^TMP("PS00",$J,"NVA",ILFD,0) as G1 aka GMRC
+11 ; (see also ^PSOHCSUM):
+12 ;
+13 ; Field Descriptions Defined AKA/Notes
+14 ; Orderable Item $P(G1,U) Includes dosage form
+15 ; (File # 50.7)
+16 ; Status $P(G1,U,2)
+17 ; Discontinued Date $P(G1,U,7) FM format
+18 ; Order # $P(G1,U,4) CPRS Order # ptr to
+19 ; File #100
+20 ; Documented By $P($P(G1,U,6),";",2) Doc. by Name ptr to
+21 ; File #200 is $P(x;1)
+22 ; Documented Date $P(G1,U,5) FM format (Entered On)
+23 ; Clinic $P($P(G2,U,5),";",2) Clinic Name ptr to
+24 ; File #44 is $P(x;1)
+25 ; Date Started $P(G1,U,3) FM format (Start Date)
+26 ; Drug $P($P(G2,U,4),";",2) Drug name (Dispensed)
+27 ; ptr to f#50 is $P(x;1)
+28 ; Dosage $P(G2,U)
+29 ; Medication Route $P(G2,U,2)
+30 ; Schedule $P(G2,U,3)
+31 ; Statement/Explanation ^TMP("PSOO",$J,"NVA",ILFD,"DSC",nn,0)
+32 ;
+33 ; where G1=^TMP("PSOO",$J,"NVA",ILFD,0)
+34 ; G2=^TMP("PSOO",$J,"NVA",ILFD,1,0)
+35 ; nn & nnn = sequentual integers
+36 ;
+37 ; Variables Descriptions
+38 ; CT Counter of number of Herbal/OTC/Non-VA drugs for patient
+39 ; DFN Patient internal number passed in
+40 ; DGR Documented by's degree
+41 ; ILFD Inverse Last Fill Date (FM format)
+42 ; JOB $J
+43 ; G1,G2 Abstracted data strings from ^TMP("PSOO", - see MAIN & WRT
+44 ; GMT* Variables used by HS pagination routine (GMTSUP), e.g.,
+45 ; GMTSLPG=last page, GMTSTITL=title
+46 ; LL* Line lengths ('^' delimited) for override reason & S/E
+47 ; NEWFORM ;
+48 ; NL Sequential line counter for override reasons &
+49 ; statement/explanation
+50 ; T1,T2,T3 Integer tab stops for data display - see MAIN
+51 ; T4 Tab stops (#,#) for override reason display
+52 ; T5 Tab stops for Stmt/Expln display
+53 ; V Line header verbiage describing data displayed
+54 ; VARY Array of verbiage to be displayed (override reason & S/E)
+55 ; Y Scratch system variable
+56 ;
+57 ; Global Variables (variables defined outside this routine)
+58 ; DFN, GMTSNPG, GMTSQIT
+59 ;
MAIN ; Herbal/Over-the-Counter/Non-VA Medications
+1 NEW CHAW,CLL,CT,DGR,G1,G2,GMTOP,GMX,I,ILFD,ILN,JOB,LINE,LL
+2 NEW LL5,LP,MAX,NL,OLN,PLN,T1,T2,T3,T4,T5,V,VARY,VO,X,Y
+3 SET ILFD=0
SET JOB=$JOB
SET LL5="40^65"
+4 SET T1=16
SET T2=58
SET T3=33
SET T4="25,10"
SET T5="33,10"
+5 ; Set variables for use by report pagination routine (GMTSUP)
+6 SET CT=0
SET MAX=999
SET GMX=0
+7 ; Check to see if a patient IEN is defined
+8 IF DFN=""
DO CKFORM
WRITE !?8,"No patient selected"
QUIT
+9 ; Check page line count and print new page and header if necessary
+10 DO CKFORM
if $DATA(GMTSQIT)
QUIT
+11 ; Output header for report
+12 if GMTSNPG!(GMX'>0)
DO HDR
if $DATA(GMTSQIT)
QUIT
DO CKFORM
if $DATA(GMTSQIT)
QUIT
+13 if 'GMTOP
WRITE !
SET GMTOP=0
SET GMX=1
+14 ; Run Pharmacy extraction
+15 ; DBIA 330
DO ^PSOHCSUM
+16 ; Quit if no herbals/non-VA drugs extracted - ^TMP("PSOO") via DBIA 330
+17 IF '$DATA(^TMP("PSOO",JOB,"NVA"))
DO CKFORM
WRITE !,?8,"No Non-VA Meds Extracted"
QUIT
+18 ; Loop through ^TMP global array created by ^PSOHCSUM ; DBIA 330
+19 ; Quit if 1 Inverse Last Fill Date =0
+20 ; 2 Counter is not less than Max Occurrence
+21 ; 3 User has "up-arrowed" out of the display
+22 FOR
SET ILFD=$ORDER(^TMP("PSOO",JOB,"NVA",ILFD))
if +ILFD=0!(CT'<MAX)!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+23 SET G1=^TMP("PSOO",JOB,"NVA",ILFD,0)
+24 SET G2=^TMP("PSOO",JOB,"NVA",ILFD,1,0)
SET CT=CT+1
+25 DO WRT
End DoDot:1
+26 ;delete temporary file created via PSOHCSUM
KILL ^TMP("PSOO",$JOB)
+27 QUIT
+28 ;
WRT ; Write Data
+1 ;line/pagination check - repeated ad nauseum
DO CKFORM
if $DATA(GMTSQIT)
QUIT
+2 if GMTSNPG!(GMX'>0)
DO HDR
if $DATA(GMTSQIT)
QUIT
+3 DO CKFORM
if $DATA(GMTSQIT)
QUIT
+4 SET V="Non-VA Med: "
WRITE !?T1-$LENGTH(V),V,$PIECE(G1,U)
+5 DO CKFORM
if $DATA(GMTSQIT)
QUIT
+6 SET V="Status: "
WRITE !?T1-$LENGTH(V),V,$PIECE(G1,U,2)
+7 ; Display discontinued date if it exists (assume discontinued status)
+8 ; DBIA 10003
SET Y=$PIECE(G1,U,7)
IF Y
DO DD^%DT
WRITE " (",$PIECE(Y,"@"),")"
+9 SET V="CPRS Order #: "
WRITE ?T2-$LENGTH(V),V,$PIECE(G1,U,4)
+10 DO CKFORM
if $DATA(GMTSQIT)
QUIT
+11 SET V="Documented By: "
WRITE !?T1-$LENGTH(V),V,$PIECE($PIECE(G1,U,6),";",2)
+12 IF $PIECE($PIECE(G1,U,6),";")
DO DEGREE
if DGR'=""
WRITE ",",DGR
+13 ; DBIA 10003
SET V="Documented Date: "
SET Y=$PIECE(G1,U,5)
DO DD^%DT
WRITE ?T2-$LENGTH(V),V,Y
+14 DO CKFORM
if $DATA(GMTSQIT)
QUIT
+15 SET V="Clinic: "
+16 WRITE !?T1-$LENGTH(V),V,$PIECE($PIECE(G2,U,5),";"),"-",$PIECE($PIECE(G2,U,5),";",2)
+17 ; DBIA 10003
SET V="Start Date: "
SET Y=$PIECE(G1,U,3)
DO DD^%DT
WRITE ?T2-$LENGTH(V),V,Y
+18 DO CKFORM
if $DATA(GMTSQIT)
QUIT
+19 SET V="Dispense Drug: "
WRITE !?T1-$LENGTH(V),V,$PIECE($PIECE(G2,U,4),";",2)
+20 SET V="Dosage: "
WRITE ?T2-$LENGTH(V),V,$PIECE(G2,U)
+21 DO CKFORM
if $DATA(GMTSQIT)
QUIT
+22 SET V="Med Route: "
WRITE !?T1-$LENGTH(V),V,$PIECE(G2,U,2)
+23 SET V="Schedule: "
WRITE ?T2-$LENGTH(V),V,$PIECE(G2,U,3)
+24 SET V="Statement/Explanation/Comment: "
SET NL=""
+25 DO CKFORM
if $DATA(GMTSQIT)
QUIT
+26 WRITE !
+27 DO CKFORM
if $DATA(GMTSQIT)
QUIT
+28 WRITE !?T3-$LENGTH(V),V
+29 KILL V
MERGE V=^TMP("PSOO",JOB,"NVA",ILFD,"DSC")
+30 ; Statement/Explanation verbiage
+31 DO LINES(LL5,.V)
KILL V
DO LINESOUT(T5)
+32 DO CKFORM
WRITE !
+33 KILL VO,X,Y
+34 QUIT
+35 ;
LINESOUT(TN) ;WRITE LINES
+1 FOR
SET NL=$ORDER(VO(NL))
if NL=""!$DATA(GMTSQIT)
QUIT
Begin DoDot:1
+2 IF NL=1
WRITE ?$PIECE(TN,","),VO(NL)
+3 IF '$TEST
DO CKFORM
if $DATA(GMTSQIT)
QUIT
WRITE !?$PIECE(T4,",",2),VO(NL)
End DoDot:1
+4 QUIT
+5 ;
LINES(LL,V) ;BREAK LINES OF AN ARRAY INTO APPROPRIATE MAX LENGTHS
+1 ;
+2 ; Input:
+3 ; LL = line lengths, e.g., 20^30^40 where last remains default
+4 ; V = input array w/ no null lines, use " " for blank line
+5 ;
+6 ;Output:
+7 ; OV = output array of lines broken into specified maximum lengths
+8 ;
+9 ; This subroutine takes an array of text (V) and breaks the text into
+10 ; line lengths as dictated via LL. Where the first line length (max)
+11 ; of the resulting array (VO) will be (approximately, based on line
+12 ; contents) $P(LL,"^",1), the second line length (max) will be
+13 ; $P(LL,"^",2), etc. The last line length in LL becomes the default
+14 ; maximum line length for all the remaining lines.
+15 ;
+16 ; This subroutine is useful if you want lines output in different
+17 ; lengths.
+18 ;
+19 ; Variables used:
+20 ; CHAW = the next piece of a line of a maximum byte length
+21 ; CLL = current line length (max)
+22 ; I = scratch variable
+23 ; ILN = input array line number
+24 ; LP = pointer indicating where in a line the last chaw taken
+25 ; OLN = output (resulting) line number
+26 ; PLN = previous line length (max)
+27 ; X = line being parsed for a breaking point
+28 ;
+29 NEW CHAW,CLL,ILN,LP,OLN,PLN
+30 KILL VO
+31 SET (I,ILN,X)=""
SET OLN=1
SET CLL=$PIECE(LL,U,OLN)
SET PLN=CLL
+32 FOR
SET ILN=$ORDER(V(ILN))
if ILN=""
QUIT
SET LP=1
Begin DoDot:1
+33 SET I=$EXTRACT($REVERSE(V(ILN,0)))
+34 SET V(ILN,0)=V(ILN,0)_$SELECT("!?."[I:" ",",;:"[I!(I?1A):" ",1:"")
+35 IF V(ILN,0)=" "
if X'=""
SET VO(OLN)=X
SET X=""
SET OLN=OLN+1
SET VO(OLN)=" "
SET OLN=OLN+1
QUIT
+36 FOR
SET CHAW=$EXTRACT(V(ILN,0),LP,LP+CLL-$LENGTH(X))
SET LP=LP+$LENGTH(CHAW)
SET X=X_CHAW
if CHAW=""!($LENGTH(X)<CLL)
QUIT
Begin DoDot:2
+37 IF $LENGTH(X)<CLL
SET VO(OLN)=X
SET X=""
DO LINESET
QUIT
+38 IF X'[" "&($LENGTH(X)=CLL)
SET VO(OLN)=X_"-"
SET X=""
DO LINESET
QUIT
+39 FOR I=$LENGTH(X):-1:1
if $EXTRACT(X,I)=" "!($EXTRACT(X,I)="-")
QUIT
+40 SET VO(OLN)=$EXTRACT(X,1,I)
SET X=$EXTRACT(X,I+1,999)
DO LINESET
End DoDot:2
End DoDot:1
+41 if X'=""
SET VO(OLN)=X
+42 QUIT
+43 ;
LINESET ; Used by LINES for setting variables
+1 SET OLN=OLN+1
SET PLN=CLL
SET CLL=$PIECE(LL,U,OLN)
if +CLL=0
SET CLL=PLN
+2 QUIT
+3 ;
CKFORM ; Checks to determine whether to do a form feed or not
+1 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+2 QUIT
+3 ;
HDR ; Prints Header
+1 SET GMTOP=1
+2 IF GMX'>0
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+3 IF 'GMTSNPG
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+4 QUIT
+5 ;
DEGREE ; Gets degree of 'Documented by' individual & converts to upper case
+1 ; DBIA 10060
SET DGR=$$GET1^DIQ(200,$PIECE($PIECE(G1,U,6),";"),10.6)
+2 SET DGR=$TRANSLATE(DGR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+3 QUIT
