GMTSUP ; SLC/KER - Utilities for Paging HS ; 01/06/2003
;;2.7;Health Summary;**2,7,21,27,28,30,35,47,56,58,85**;Oct 20, 1995;Build 24
;
; External References
; DBIA 10026 ^DIR
; DBIA 82 EN^XQORM
;
CKP ; Check page position, pause and prompt
Q:$D(GMTSQIT) S GMTSNPG=0
K:$L($G(GMTSOBJ("LABEL"))) GMTSOBJ("REPORT HEADER")
I $G(GMTSWRIT)=1 D BREAK S GMTSWRIT=0
I +($$HF^GMTSU) D BREAK:(GMTSEGN'=$G(GMTSLCMP)) Q
Q:+$G(GMTSLPG)'>0&($Y'>(IOSL-GMTSLO))
I $E(IOST,1)="C" S:'$D(GMTSTOF) GMTSTOF=1 D CKP1
I '$D(GMTSQIT) W @IOF D HEADER,BREAK S GMTSNPG=1,GMTSTOF=GMTSEGN
I $D(GMTSQIT),(GMTSQIT]""),($D(GMTSTYP)) W @IOF D HEADER S GMTSTOF=GMTSEGN
Q
CKP1 ; Help Display of Optional Components for Navigation
N DA,I,J,K,L,X,XQORM,Y,GMTSY,TYP,DIC
I $S('$D(GMTSTYP):1,$D(GMTOPT):1,1:0) N DIR S DIR(0)="E" D ^DIR K DIR S:$D(DUOUT)!(GMTSLPG) GMTSQIT="" Q
S TYP=GMTSTYP
S DIC=142,DIC(0)="MZF",X="GMTS HS ADHOC OPTION" S Y=$$TYPE^GMTSULT
S GMTSTYP=+Y K DIC,X,Y
S XQORM=GMTSTYP_";GMT(142,",XQORM(0)="1AF\+",XQORM("A")="Press <RET> to continue, ^ to exit, or select component: "
S XQORM("??")="D HELP^GMTSUP1" I GMTSLPG,'$D(GMTSOBJ) W:'$D(GMTSOBJE) "* END * "
S XQORM("S")="I $D(^GMT(142,DA(1),1,DA,0)),($P(^GMT(142.1,$P(^GMT(142,DA(1),1,DA,0),U,2),0),U,6)'=""T"")"
D EN^XQORM W ! D @$S(Y=1:"BRNCH",1:"EVAL")
I $D(GMTSY),(GMTSY=0) K GMTSY G CKP1
S GMTSTYP=TYP
Q
BREAK ; Writes the Component Header
;
; If the variable GMTSOBJ exist, then the
; Component Headers are suppressed with the
; following exceptions:
;
; If GMTSOBJ("COMPONENT HEADER") exist,
; then the Component Header will NOT be
; suppressed
;
; If GMTSOBJ("BLANK LINE") exist, a blank
; line will be written after the Component
; Header
;
N GMTSM,GMTSF S GMTSM=$$MUL,GMTSF=$$FST
I +GMTSM=0,$D(GMTSOBJ),'$D(GMTSOBJ("COMPONENT HEADER")),'$D(GMTSOBJ("BLANK LINE")) Q
N GMTS,GMTSUL,GMTSL S:'$D(GMTSLCMP) GMTSLCMP=0
S GMTSUL="",GMTSNPG=1,GMTS=$$CHDR,GMTSL=+($L($G(GMTS))),$P(GMTSUL,"-",+GMTSL)="-"
I $Y'>(IOSL-GMTSLO)!(+($$HF^GMTSU)) D
. I $D(GMTSOBJ) D Q
. . S GMTSLCMP=GMTSEGN
. . I +($G(GMTSM))>0!($D(GMTSOBJ("COMPONENT HEADER"))) D
. . . W:+GMTSF=0 ! W !,GMTS W:$D(GMTSOBJ("UNDERLINE")) !,GMTSUL
. . . W ! W:$D(GMTSOBJ("BLANK LINE")) !
. W !,GMTS,!
. W:$Y'>(IOSL-GMTSLO) ?34,$S(GMTSEGN=GMTSLCMP:"(continued)",1:""),!
. S GMTSLCMP=GMTSEGN
Q
OLDB ;
S:'$D(GMTSLCMP) GMTSLCMP=0
S GMTS="",GMTSNPG=1
S $P(GMTS,"-",79-$L(GMTSEGH_GMTSEGL)/2)=""
S GMTS=GMTS_" "_GMTSEGH_GMTSEGL_" "_GMTS
I $Y'>(IOSL-GMTSLO)!(+($$HF^GMTSU)) D
. W !,GMTS,!
. W:$Y'>(IOSL-GMTSLO) ?34,$S(GMTSEGN=GMTSLCMP:"(continued)",1:""),!
. S GMTSLCMP=GMTSEGN
Q
;
; If the variable GMTSOBJ exist, then the
; Report Headers are suppressed with the
; following exceptions:
;
; If GMTSOBJ("DATE LINE") exist, then the
; Location/Report Date line will NOT be
; suppressed.
;
; If GMTSOBJ("CONFIDENTIAL") exist, then
; the Confidential Header Name line will
; NOT be suppressed.
;
; If GMTSOBJ("REPORT HEADER") exist, then
; the Report Header containing the patient's
; name, SSAN, ward and DOB will NOT be
; suppressed.
;
; If the variable GMTSOBJ("LABEL") contains
; text, and the variable GMTSOBJ("USE LABEL")
; exist, then this text will be printed before
; the object text.
;
; If GMTSOBJ("REPORT DECEASED") exist, then
; the optional line that displays for Deceased
; patients will NOT be suppressed.
;
; Header Lines:
N GMTSVDT,DATA S DATA="" I +$G(GMTSPXD1)&+$G(GMTSPXD2) D
. Q:$G(GMTSOBJ) S:'$D(GMTSOBJE) DATA="Printed for data " S:$D(GMTSOBJE) DATA="Include data "
. I GMTSPXD1=GMTSPXD2 S DATA=DATA_"on "_GMTSPXD1 Q
. S DATA=DATA_"from "_GMTSPXD2_" to "_GMTSPXD1
I $D(GMTSCDT(0)),'$D(GMTSOBJ) S GMTSVDT=GMTSCDT(0) S:GMTSDTM'["Printed:" GMTSDTM="Printed: "_GMTSDTM
; Location and Date of Report
I '$D(GMTSOBJ)!($D(GMTSOBJ("DATE LINE"))) D
. N GMTSLOC S GMTSLOC=$S('$D(GMTSOBJ("DATE LINE")):$P($G(GMTSSC),U,2),1:"")
. W !,$S($L(GMTSLOC):"Location: "_GMTSLOC_" ",1:"")
. W $S($D(GMTSVDT):GMTSVDT,1:"")
. W:'$D(GMTSOBJ("DATE LINE")) DATA,?(79-$L(GMTSDTM)),GMTSDTM
. W:$D(GMTSOBJ("DATE LINE")) DATA,?(74-$L(GMTSDTM)),GMTSDTM
; Confidential Header Name
S:'$D(GMTSPG) GMTSPG=0
S GMTSPG=GMTSPG+1,GMTSHDR=" CONFIDENTIAL "_GMTSTITL_" SUMMARY "
S GMTSHDR=GMTSHDR_$S($E(IOST,1)="C":"",1:" pg. "_GMTSPG)
S GMTS="" S:'$D(GMTSOBJ) $P(GMTS,"*",(77-$L(GMTSHDR))\2)="*"
S:$D(GMTSOBJ) $P(GMTS,"*",(72-$L(GMTSHDR))\2)="*"
S GMTSHDR=GMTS_" "_GMTSHDR_" "_GMTS
I '$D(GMTSOBJ)!($D(GMTSOBJ("CONFIDENTIAL"))) W !,GMTSHDR,"*"
; Name, SSAN, Ward, DOB
I '$D(GMTSLFG) D
.I $G(GMTSTITL)'["AD HOC",($G(GMTSTITL)'["PDX"),($G(HSTAG)="") D EN^GMTSHCPR ;GMTS,85 restrict ssn/dob on HS Type hard copies
. I $G(GMTSPHDR("TWO")) D
. . I $D(GMTSOBJ),'$D(GMTSOBJ("REPORT HEADER")),$L($G(GMTSOBJ("LABEL"))) D LABEL
. . I $D(GMTSOBJ),'$D(GMTSOBJ("REPORT HEADER")) Q
. . W !,GMTSPHDR("NMSSN"),?GMTSPHDR("DOBS"),GMTSPHDR("DOB")
. . W !,?GMTSPHDR("WARDRBS"),GMTSPHDR("WARDRB")
. E D
. . I $D(GMTSOBJ),'$D(GMTSOBJ("REPORT HEADER")),$L($G(GMTSOBJ("LABEL"))) D LABEL
. . I $D(GMTSOBJ),'$D(GMTSOBJ("REPORT HEADER")) Q
. . W !,GMTSPHDR("NMSSN"),?GMTSPHDR("WARDRBS")
. . W GMTSPHDR("WARDRB"),?GMTSPHDR("DOBS"),GMTSPHDR("DOB")
; Deceased
;
I '$D(GMTSOBJ)!($D(GMTSOBJ("DECEASED"))) D
. W:+$G(VADM(6)) !,?26,"** DECEASED "_$P(VADM(6),U,2)_" **"
W:'$D(GMTSOBJ) !
Q
BRNCH ; Checks abbreviation to branch to a different component
N GMTINX,LIM,CREC,SBS
I Y,("+-"[X) S:X="-" GMTSEGN=GMTSTOF-1 S (GMTSY,GMTSQIT)=1,GMTSLPG=0 Q
I X="^^" S DIROUT=1,GMTSQIT="" Q
I Y,(X?1"^^".E) Q
S GMTINX=$S($D(^GMT(142,GMTSTYP,1,+Y(1),0)):$P(^(0),U,2),1:"")
I 'GMTINX S GMTSY=0 Q
I '$D(GMTSEGI(GMTINX)) N GMI,GMJ,GMTSDFLT S GMI=1,GMJ=GMTSEGC,GMTSDFLT=1 D LOAD^GMTSADH S GMTSEGC=GMTSEGC+1
I '$D(GMTSEGI(GMTINX)) S GMTINX="",GMTSY=0 Q
S LIM=$P(Y(1),U,4) I LIM'["=" G NOLIM
S CREC=^GMT(142.1,GMTINX,0),SBS=GMTSEGI(GMTINX) D CMPLIM^GMTSADH2
I $D(DIROUT) S GMTSQIT="" Q
NOLIM ; No limits
S GMTSEGN=GMTSEGI(GMTINX)-1,(GMTSY,GMTSQIT)=1,GMTSLPG=0
Q
;
EVAL ; Evaluate input to determine quit or continue
Q:'$D(X)
S:$D(GMTSEXIT) GMTSEXIT=$G(X)
S:$D(DTOUT) DIROUT=1 I $S(X="^^":1,GMTSLPG:1,$D(DIROUT):1,X="^":1,1:0) S GMTSQIT=""
I +$G(GMPSAP),(X="^") S GMDUOUT=1
Q
MUL(X) ; Multiple Components in Type
N GMTSF,GMTSL S GMTSF=$O(GMTSEG(0)),GMTSL=$O(GMTSEG(" "),-1)
Q:+GMTSF=+GMTSL 0 Q 1
FST(X) ; First Component in Type
N GMTSF,GMTSL S GMTSF=$O(GMTSEG(0)),GMTSL=+($G(GMTSEGN))
Q:+GMTSF=+GMTSL 1 Q 0
CHDR(X) ; Component Header
N GMTSN,GMTSH,GMTSL,GMTS S GMTSN=$$CNAM,GMTSH=$G(GMTSEGH)
S GMTSL=$G(GMTSEGL),GMTS="",$P(GMTS,"-",79-$L(GMTSH_GMTSL)/2)=""
S X=GMTS_" "_GMTSH_GMTSL_" "_GMTS Q:'$D(GMTSOBJ) X
S:$L(GMTSH)&($D(GMTSOBJ("COMPONENT HEADER"))) GMTSN=GMTSH
S:$L(GMTSL)&($L(GMTSN))&($D(GMTSOBJ("LIMITS"))) GMTSN=GMTSN_" "_GMTSL
S X=GMTSN Q X
CNAM(X) ; Component Name
N GMTSH S GMTSH=+($P($G(GMTSEG(+($G(GMTSEGN)))),"^",2))
S X=$P($G(^GMT(142.1,+GMTSH,0)),"^",1) Q X
LABEL ; Label
Q:'$D(GMTSOBJ("USE LABEL")) N LABEL S LABEL=$G(GMTSOBJ("LABEL"))
W !,LABEL W:$L(LABEL) ! W:$D(GMTSOBJ("LABEL BLANK LINE")) !
Q
LABDAT ; Label/Date
Q:'$D(GMTSOBJ("USE LABEL")) N LABEL S LABEL=$G(GMTSOBJ("LABEL"))
I '$D(GMTSOBJ("DATE LINE")),$D(GMTSOBJ("LABEL")),$L(LABEL),$L($G(GMTSDTM)) S LABEL=LABEL_$J("",((79-$L(GMTSDTM))-$L(LABEL)))_GMTSDTM
I '$D(GMTSOBJ("DATE LINE")),$D(GMTSOBJ("LABEL")),'$L(LABEL),$L($G(GMTSDTM)) S LABEL="Information as of "_$G(GMTSDTM)
W !,LABEL W:$L(LABEL) ! W:$D(GMTSOBJ("LABEL BLANK LINE")) !
Q
GMTSUP ; SLC/KER - Utilities for Paging HS ; 01/06/2003
+1 ;;2.7;Health Summary;**2,7,21,27,28,30,35,47,56,58,85**;Oct 20, 1995;Build 24
+2 ;
+3 ; External References
+4 ; DBIA 10026 ^DIR
+5 ; DBIA 82 EN^XQORM
+6 ;
CKP ; Check page position, pause and prompt
+1 IF $DATA(GMTSQIT)
QUIT
SET GMTSNPG=0
+2 IF $LENGTH($GET(GMTSOBJ("LABEL")))
KILL GMTSOBJ("REPORT HEADER")
+3 IF $GET(GMTSWRIT)=1
DO BREAK
SET GMTSWRIT=0
+4 IF +($$HF^GMTSU)
IF (GMTSEGN'=$GET(GMTSLCMP))
DO BREAK
QUIT
+5 IF +$GET(GMTSLPG)'>0&($Y'>(IOSL-GMTSLO))
QUIT
+6 IF $EXTRACT(IOST,1)="C"
IF '$DATA(GMTSTOF)
SET GMTSTOF=1
DO CKP1
+7 IF '$DATA(GMTSQIT)
WRITE @IOF
DO HEADER
DO BREAK
SET GMTSNPG=1
SET GMTSTOF=GMTSEGN
+8 IF $DATA(GMTSQIT)
IF (GMTSQIT]"")
IF ($DATA(GMTSTYP))
WRITE @IOF
DO HEADER
SET GMTSTOF=GMTSEGN
+9 QUIT
CKP1 ; Help Display of Optional Components for Navigation
+1 NEW DA,I,J,K,L,X,XQORM,Y,GMTSY,TYP,DIC
+2 IF $SELECT('$DATA(GMTSTYP):1,$DATA(GMTOPT):1,1:0)
NEW DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)!(GMTSLPG)
SET GMTSQIT=""
QUIT
+3 SET TYP=GMTSTYP
+4 SET DIC=142
SET DIC(0)="MZF"
SET X="GMTS HS ADHOC OPTION"
SET Y=$$TYPE^GMTSULT
+5 SET GMTSTYP=+Y
KILL DIC,X,Y
+6 SET XQORM=GMTSTYP_";GMT(142,"
SET XQORM(0)="1AF\+"
SET XQORM("A")="Press <RET> to continue, ^ to exit, or select component: "
+7 SET XQORM("??")="D HELP^GMTSUP1"
IF GMTSLPG
IF '$DATA(GMTSOBJ)
IF '$DATA(GMTSOBJE)
WRITE "* END * "
+8 SET XQORM("S")="I $D(^GMT(142,DA(1),1,DA,0)),($P(^GMT(142.1,$P(^GMT(142,DA(1),1,DA,0),U,2),0),U,6)'=""T"")"
+9 DO EN^XQORM
WRITE !
DO @$SELECT(Y=1:"BRNCH",1:"EVAL")
+10 IF $DATA(GMTSY)
IF (GMTSY=0)
KILL GMTSY
GOTO CKP1
+11 SET GMTSTYP=TYP
+12 QUIT
BREAK ; Writes the Component Header
+1 ;
+2 ; If the variable GMTSOBJ exist, then the
+3 ; Component Headers are suppressed with the
+4 ; following exceptions:
+5 ;
+6 ; If GMTSOBJ("COMPONENT HEADER") exist,
+7 ; then the Component Header will NOT be
+8 ; suppressed
+9 ;
+10 ; If GMTSOBJ("BLANK LINE") exist, a blank
+11 ; line will be written after the Component
+12 ; Header
+13 ;
+14 NEW GMTSM,GMTSF
SET GMTSM=$$MUL
SET GMTSF=$$FST
+15 IF +GMTSM=0
IF $DATA(GMTSOBJ)
IF '$DATA(GMTSOBJ("COMPONENT HEADER"))
IF '$DATA(GMTSOBJ("BLANK LINE"))
QUIT
+16 NEW GMTS,GMTSUL,GMTSL
IF '$DATA(GMTSLCMP)
SET GMTSLCMP=0
+17 SET GMTSUL=""
SET GMTSNPG=1
SET GMTS=$$CHDR
SET GMTSL=+($LENGTH($GET(GMTS)))
SET $PIECE(GMTSUL,"-",+GMTSL)="-"
+18 IF $Y'>(IOSL-GMTSLO)!(+($$HF^GMTSU))
Begin DoDot:1
+19 IF $DATA(GMTSOBJ)
Begin DoDot:2
+20 SET GMTSLCMP=GMTSEGN
+21 IF +($GET(GMTSM))>0!($DATA(GMTSOBJ("COMPONENT HEADER")))
Begin DoDot:3
+22 IF +GMTSF=0
WRITE !
WRITE !,GMTS
IF $DATA(GMTSOBJ("UNDERLINE"))
WRITE !,GMTSUL
+23 WRITE !
IF $DATA(GMTSOBJ("BLANK LINE"))
WRITE !
End DoDot:3
End DoDot:2
QUIT
+24 WRITE !,GMTS,!
+25 IF $Y'>(IOSL-GMTSLO)
WRITE ?34,$SELECT(GMTSEGN=GMTSLCMP:"(continued)",1:""),!
+26 SET GMTSLCMP=GMTSEGN
End DoDot:1
+27 QUIT
OLDB ;
+1 IF '$DATA(GMTSLCMP)
SET GMTSLCMP=0
+2 SET GMTS=""
SET GMTSNPG=1
+3 SET $PIECE(GMTS,"-",79-$LENGTH(GMTSEGH_GMTSEGL)/2)=""
+4 SET GMTS=GMTS_" "_GMTSEGH_GMTSEGL_" "_GMTS
+5 IF $Y'>(IOSL-GMTSLO)!(+($$HF^GMTSU))
Begin DoDot:1
+6 WRITE !,GMTS,!
+7 IF $Y'>(IOSL-GMTSLO)
WRITE ?34,$SELECT(GMTSEGN=GMTSLCMP:"(continued)",1:""),!
+8 SET GMTSLCMP=GMTSEGN
End DoDot:1
+9 QUIT
+1 ;
+2 ; If the variable GMTSOBJ exist, then the
+3 ; Report Headers are suppressed with the
+4 ; following exceptions:
+5 ;
+6 ; If GMTSOBJ("DATE LINE") exist, then the
+7 ; Location/Report Date line will NOT be
+8 ; suppressed.
+9 ;
+10 ; If GMTSOBJ("CONFIDENTIAL") exist, then
+11 ; the Confidential Header Name line will
+12 ; NOT be suppressed.
+13 ;
+14 ; If GMTSOBJ("REPORT HEADER") exist, then
+15 ; the Report Header containing the patient's
+16 ; name, SSAN, ward and DOB will NOT be
+17 ; suppressed.
+18 ;
+19 ; If the variable GMTSOBJ("LABEL") contains
+20 ; text, and the variable GMTSOBJ("USE LABEL")
+21 ; exist, then this text will be printed before
+22 ; the object text.
+23 ;
+24 ; If GMTSOBJ("REPORT DECEASED") exist, then
+25 ; the optional line that displays for Deceased
+26 ; patients will NOT be suppressed.
+27 ;
+28 ; Header Lines:
+29 NEW GMTSVDT,DATA
SET DATA=""
IF +$GET(GMTSPXD1)&+$GET(GMTSPXD2)
Begin DoDot:1
+30 IF $GET(GMTSOBJ)
QUIT
IF '$DATA(GMTSOBJE)
SET DATA="Printed for data "
IF $DATA(GMTSOBJE)
SET DATA="Include data "
+31 IF GMTSPXD1=GMTSPXD2
SET DATA=DATA_"on "_GMTSPXD1
QUIT
+32 SET DATA=DATA_"from "_GMTSPXD2_" to "_GMTSPXD1
End DoDot:1
+33 IF $DATA(GMTSCDT(0))
IF '$DATA(GMTSOBJ)
SET GMTSVDT=GMTSCDT(0)
IF GMTSDTM'["Printed
SET GMTSDTM="Printed: "_GMTSDTM
+34 ; Location and Date of Report
+35 IF '$DATA(GMTSOBJ)!($DATA(GMTSOBJ("DATE LINE")))
Begin DoDot:1
+36 NEW GMTSLOC
SET GMTSLOC=$SELECT('$DATA(GMTSOBJ("DATE LINE")):$PIECE($GET(GMTSSC),U,2),1:"")
+37 WRITE !,$SELECT($LENGTH(GMTSLOC):"Location: "_GMTSLOC_" ",1:"")
+38 WRITE $SELECT($DATA(GMTSVDT):GMTSVDT,1:"")
+39 IF '$DATA(GMTSOBJ("DATE LINE"))
WRITE DATA,?(79-$LENGTH(GMTSDTM)),GMTSDTM
+40 IF $DATA(GMTSOBJ("DATE LINE"))
WRITE DATA,?(74-$LENGTH(GMTSDTM)),GMTSDTM
End DoDot:1
+41 ; Confidential Header Name
+42 IF '$DATA(GMTSPG)
SET GMTSPG=0
+43 SET GMTSPG=GMTSPG+1
SET GMTSHDR=" CONFIDENTIAL "_GMTSTITL_" SUMMARY "
+44 SET GMTSHDR=GMTSHDR_$SELECT($EXTRACT(IOST,1)="C":"",1:" pg. "_GMTSPG)
+45 SET GMTS=""
IF '$DATA(GMTSOBJ)
SET $PIECE(GMTS,"*",(77-$LENGTH(GMTSHDR))\2)="*"
+46 IF $DATA(GMTSOBJ)
SET $PIECE(GMTS,"*",(72-$LENGTH(GMTSHDR))\2)="*"
+47 SET GMTSHDR=GMTS_" "_GMTSHDR_" "_GMTS
+48 IF '$DATA(GMTSOBJ)!($DATA(GMTSOBJ("CONFIDENTIAL")))
WRITE !,GMTSHDR,"*"
+49 ; Name, SSAN, Ward, DOB
+50 IF '$DATA(GMTSLFG)
Begin DoDot:1
+51 ;GMTS,85 restrict ssn/dob on HS Type hard copies
IF $GET(GMTSTITL)'["AD HOC"
IF ($GET(GMTSTITL)'["PDX")
IF ($GET(HSTAG)="")
DO EN^GMTSHCPR
+52 IF $GET(GMTSPHDR("TWO"))
Begin DoDot:2
+53 IF $DATA(GMTSOBJ)
IF '$DATA(GMTSOBJ("REPORT HEADER"))
IF $LENGTH($GET(GMTSOBJ("LABEL")))
DO LABEL
+54 IF $DATA(GMTSOBJ)
IF '$DATA(GMTSOBJ("REPORT HEADER"))
QUIT
+55 WRITE !,GMTSPHDR("NMSSN"),?GMTSPHDR("DOBS"),GMTSPHDR("DOB")
+56 WRITE !,?GMTSPHDR("WARDRBS"),GMTSPHDR("WARDRB")
End DoDot:2
+57 IF '$TEST
Begin DoDot:2
+58 IF $DATA(GMTSOBJ)
IF '$DATA(GMTSOBJ("REPORT HEADER"))
IF $LENGTH($GET(GMTSOBJ("LABEL")))
DO LABEL
+59 IF $DATA(GMTSOBJ)
IF '$DATA(GMTSOBJ("REPORT HEADER"))
QUIT
+60 WRITE !,GMTSPHDR("NMSSN"),?GMTSPHDR("WARDRBS")
+61 WRITE GMTSPHDR("WARDRB"),?GMTSPHDR("DOBS"),GMTSPHDR("DOB")
End DoDot:2
End DoDot:1
+62 ; Deceased
+63 ;
+64 IF '$DATA(GMTSOBJ)!($DATA(GMTSOBJ("DECEASED")))
Begin DoDot:1
+65 IF +$GET(VADM(6))
WRITE !,?26,"** DECEASED "_$PIECE(VADM(6),U,2)_" **"
End DoDot:1
+66 IF '$DATA(GMTSOBJ)
WRITE !
+67 QUIT
BRNCH ; Checks abbreviation to branch to a different component
+1 NEW GMTINX,LIM,CREC,SBS
+2 IF Y
IF ("+-"[X)
IF X="-"
SET GMTSEGN=GMTSTOF-1
SET (GMTSY,GMTSQIT)=1
SET GMTSLPG=0
QUIT
+3 IF X="^^"
SET DIROUT=1
SET GMTSQIT=""
QUIT
+4 IF Y
IF (X?1"^^".E)
QUIT
+5 SET GMTINX=$SELECT($DATA(^GMT(142,GMTSTYP,1,+Y(1),0)):$PIECE(^(0),U,2),1:"")
+6 IF 'GMTINX
SET GMTSY=0
QUIT
+7 IF '$DATA(GMTSEGI(GMTINX))
NEW GMI,GMJ,GMTSDFLT
SET GMI=1
SET GMJ=GMTSEGC
SET GMTSDFLT=1
DO LOAD^GMTSADH
SET GMTSEGC=GMTSEGC+1
+8 IF '$DATA(GMTSEGI(GMTINX))
SET GMTINX=""
SET GMTSY=0
QUIT
+9 SET LIM=$PIECE(Y(1),U,4)
IF LIM'["="
GOTO NOLIM
+10 SET CREC=^GMT(142.1,GMTINX,0)
SET SBS=GMTSEGI(GMTINX)
DO CMPLIM^GMTSADH2
+11 IF $DATA(DIROUT)
SET GMTSQIT=""
QUIT
NOLIM ; No limits
+1 SET GMTSEGN=GMTSEGI(GMTINX)-1
SET (GMTSY,GMTSQIT)=1
SET GMTSLPG=0
+2 QUIT
+3 ;
EVAL ; Evaluate input to determine quit or continue
+1 IF '$DATA(X)
QUIT
+2 IF $DATA(GMTSEXIT)
SET GMTSEXIT=$GET(X)
+3 IF $DATA(DTOUT)
SET DIROUT=1
IF $SELECT(X="^^":1,GMTSLPG:1,$DATA(DIROUT):1,X="^":1,1:0)
SET GMTSQIT=""
+4 IF +$GET(GMPSAP)
IF (X="^")
SET GMDUOUT=1
+5 QUIT
MUL(X) ; Multiple Components in Type
+1 NEW GMTSF,GMTSL
SET GMTSF=$ORDER(GMTSEG(0))
SET GMTSL=$ORDER(GMTSEG(" "),-1)
+2 IF +GMTSF=+GMTSL
QUIT 0
QUIT 1
FST(X) ; First Component in Type
+1 NEW GMTSF,GMTSL
SET GMTSF=$ORDER(GMTSEG(0))
SET GMTSL=+($GET(GMTSEGN))
+2 IF +GMTSF=+GMTSL
QUIT 1
QUIT 0
CHDR(X) ; Component Header
+1 NEW GMTSN,GMTSH,GMTSL,GMTS
SET GMTSN=$$CNAM
SET GMTSH=$GET(GMTSEGH)
+2 SET GMTSL=$GET(GMTSEGL)
SET GMTS=""
SET $PIECE(GMTS,"-",79-$LENGTH(GMTSH_GMTSL)/2)=""
+3 SET X=GMTS_" "_GMTSH_GMTSL_" "_GMTS
IF '$DATA(GMTSOBJ)
QUIT X
+4 IF $LENGTH(GMTSH)&($DATA(GMTSOBJ("COMPONENT HEADER")))
SET GMTSN=GMTSH
+5 IF $LENGTH(GMTSL)&($LENGTH(GMTSN))&($DATA(GMTSOBJ("LIMITS")))
SET GMTSN=GMTSN_" "_GMTSL
+6 SET X=GMTSN
QUIT X
CNAM(X) ; Component Name
+1 NEW GMTSH
SET GMTSH=+($PIECE($GET(GMTSEG(+($GET(GMTSEGN)))),"^",2))
+2 SET X=$PIECE($GET(^GMT(142.1,+GMTSH,0)),"^",1)
QUIT X
LABEL ; Label
+1 IF '$DATA(GMTSOBJ("USE LABEL"))
QUIT
NEW LABEL
SET LABEL=$GET(GMTSOBJ("LABEL"))
+2 WRITE !,LABEL
IF $LENGTH(LABEL)
WRITE !
IF $DATA(GMTSOBJ("LABEL BLANK LINE"))
WRITE !
+3 QUIT
LABDAT ; Label/Date
+1 IF '$DATA(GMTSOBJ("USE LABEL"))
QUIT
NEW LABEL
SET LABEL=$GET(GMTSOBJ("LABEL"))
+2 IF '$DATA(GMTSOBJ("DATE LINE"))
IF $DATA(GMTSOBJ("LABEL"))
IF $LENGTH(LABEL)
IF $LENGTH($GET(GMTSDTM))
SET LABEL=LABEL_$JUSTIFY("",((79-$LENGTH(GMTSDTM))-$LENGTH(LABEL)))_GMTSDTM
+3 IF '$DATA(GMTSOBJ("DATE LINE"))
IF $DATA(GMTSOBJ("LABEL"))
IF '$LENGTH(LABEL)
IF $LENGTH($GET(GMTSDTM))
SET LABEL="Information as of "_$GET(GMTSDTM)
+4 WRITE !,LABEL
IF $LENGTH(LABEL)
WRITE !
IF $DATA(GMTSOBJ("LABEL BLANK LINE"))
WRITE !
+5 QUIT
