- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSUP 8091 printed Jan 18, 2025@03:01:50 Page 2
- 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