- GMTSU ;SLC/JER,KER - Health Summary Utilities ;Jul 21, 2023@12:36
- ;;2.7;Health Summary;**27,28,31,35,37,43,47,56,144**;Oct 20, 1995;Build 17
- ;
- ; External References
- ; DBIA 10096 ^%ZOSF("TEST")
- ; DBIA 2934 ^A7RCP (NDBI Global)
- ; DBIA 10103 $$FMTE^XLFDT
- ; DBIA 10103 $$FMTHL7^XLFDT
- ; DBIA 10103 $$HL7TFM^XLFDT
- ; DBIA 10061 OERR^VADPT
- ; DBIA 10104 $$UP^XLFSTR
- ; DBIA 10026 ^DIR
- ; DBIA 2052 FILE^DID
- ; DBIA 10022 %XY^%RCR
- ; DBIA 2055 $$VFIELD^DILFD
- ; DBIA 2052 $$GET1^DID
- ;
- PROK(X,Y) ; Routine and Patch # OK (in UCI)
- N GMTS,GMTSI,GMTSO S X=$G(X),Y=$G(Y) Q:'$L(X) 0 Q:Y'=""&(+Y=0)
- S Y=+Y,GMTS=$$ROK(X) Q:'GMTS 0 Q:+Y=0 1 S GMTSO=0,GMTS=$T(@("+2^"_X)),GMTS=$P($P(GMTS,"**",2),"**",1)
- F GMTSI=1:1:$L(GMTS,",") S:+($P(GMTS,",",GMTSI))=Y GMTSO=1 Q:GMTSO=1
- S X=GMTSO Q X
- ROK(X) ; Routine OK (in UCI) (NDBI)
- S X=$G(X) Q:'$L(X) 0 Q:$L(X)>8 0 X ^%ZOSF("TEST") Q:$T 1 Q 0
- NDBI(X) ; National Database Integration site 1 = yes 0 = no
- N R,G S X="A7RDUP" X ^%ZOSF("TEST") S R=$T,G=$S($D(^A7RCP):1,1:0),X=R+G,X=$S(X=2:1,1:0) Q X
- ;
- CPT(X) ; Use CPT Modifiers Needs GMTSEG Array
- S X=+($G(X)) N GMTSN,GMTSC,GMTSM,GMTSA,GMTSI S GMTSN=$G(GMTSEG(X)) S GMTSC=+($P(GMTSN,"^",2)) Q:'GMTSC 0
- S GMTSM=$S($P(GMTSN,"^",9)="N":0,$P(GMTSN,"^",9)="":1,1:1) Q:'GMTSM 0
- S GMTSA=$S(+($$CMU(+GMTSC))>0:1,1:0) Q:'GMTSA 0
- Q 1
- CMU(X) ; Component Uses CPT Modifiers
- N GMTSA,GMTSN,GMTSI S X=$G(X) Q:'$L(X) 0 S GMTSI=+X,GMTSA=$O(^GMT(142.1,"C",X,0)),GMTSN=$O(^GMT(142.1,"D",X,0)) S:GMTSI=0&(+GMTSA>0) GMTSI=GMTSA S:GMTSI=0&(+GMTSN>0) GMTSI=GMTSN
- Q:+GMTSI=0 0 S GMTSA=$S($P($G(^GMT(142.1,+GMTSI,0)),"^",14)="Y":1,1:0) Q:'GMTSA 0
- Q 1
- ;
- ; Dates and Time
- ED(X) ; Health Summary External Date
- S X=$G(X) Q:'$L(X) "" D REGDT4 Q X
- EDT(X) ; Health Summary External Date and Time
- S X=$G(X) Q:'$L(X) "" D REGDTM4 Q X
- REGDT ; Receives X FM date and returns X in MM/DD/YY format
- S X=$TR($$FMTE^XLFDT(X,"2DZ"),"@"," ") Q
- REGDT4 ; Receives X FM date and returns X in MM/DD/YYYY format
- S X=$TR($$FMTE^XLFDT(X,"5DZ"),"@"," ") Q
- REGDTM ; Receives X FM date and returns X in MM/DD/YY TT:TT
- S X=$TR($$FMTE^XLFDT(X,"2ZM"),"@"," ") Q
- REGDTM4 ; Receives X FM date and returns X in MM/DD/YYYY TT:TT
- S X=$TR($$FMTE^XLFDT(X,"5ZM"),"@"," ") Q
- SIDT ; Receives X FM date and returns X in DD MMM YY
- N MON,MM S X=$P(X,".") S:'X X="" Q:'$L(X)
- S MON="JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC"
- S MM=$E(X,4,5),MM=$S(MM:$P(MON,U,+MM),1:"")
- S X=$E(X,6,7)_" "_MM_" "_$E(X,2,3) Q
- MTIM ; Convert Time from X=2890313.1304 to X=13:04
- S X=$P(X,".",2) Q:'$L(X) S X=$S(X:$E(X,1,2)_$E("00",0,2-$L($E(X,1,2)))_":"_$E(X,3,4)_$E("00",0,2-$L($E(X,3,4))),1:"")
- Q
- ;
- HF(X) ; Host File - Used to distinguish from Host Files that
- ; are intended for Printers and Host Files for other
- ; purposes (windows/files)
- ;
- ; 1 - if Device Type is HFS and not a TCP/IP Printer
- ; 0 - if Device Type is not HFS or device is a Printer
- ;
- ; Check Device
- ; Check Host File Server
- Q:$G(IOT)'="HFS" 0
- ; Check ORWINDEV (Post OR*3.0*85)
- N GMTS85 S GMTS85=$$PROK("ORWRP",85)
- Q:+($G(GMTS85))>0&(+($G(ORWINDEV))>0) 0
- ; Host File for GUI Scrollable Window
- Q:$E($G(ION),1,14)["OR WORKSTATION" 1
- ; TCP/IP Printer
- Q:$G(IO)["$PRT"!($G(IO)["PRN|") 0
- ; Windows Printer
- Q:$E($G(ION),1,14)["OR WINDOWS HFS" 0
- ; Host Files (file or unspecifed printer)
- S X=0 S:$G(ION)["HOST FILE" X=1
- S:$E($G(IOST),1,5)["P-OTH" X=1
- Q X
- ;
- FMHL7DTM ; Convert X - int date/time to HL7 CCYYMMDDHHMM-HHHH
- S X=$$FMTHL7^XLFDT(+($G(X))) Q
- HL7FMDTM ; Convert X - HL7 CCYYMMDDHHMM-HHHH to int date/time local
- S X=$$HL7TFM^XLFDT($G(X),"L") Q
- ;
- DEM ; Gets Demographic Data from VADPT
- ;
- ; Input DFN
- ;
- ; Output GMTSPNM Patient Name
- ; GMTSSN Social Security Number
- ; GMTSDOB Date of Birth
- ; SEX Sex
- ; GMTSWARD Ward
- ; GMTSRB Bed
- ; GMTSAGE Age
- ; VADM() Demographic Array
- ; VAIN() Inpatient Array
- ; GMTSPHDR() Report Header Array
- ;
- K VAHOW D OERR^VADPT S GMTSPNM=VADM(1),GMTSSN=$S($D(VA("PID")):VA("PID"),1:$P(VADM(2),"^",2))
- S GMTSAGE=$S(+VADM(4)>0:+VADM(4),1:99),SEX=$P(VADM(5),"^")
- S GMTSWARD=$P(VAIN(4),"^",2),GMTSRB=VAIN(5)
- S X=$P(VADM(3),"^") D REGDT4 S GMTSDOB=X K VA,GMTSPHDR N DOB,LWARDRB,NMSSN,NMSSNE,WARDRB,WARDRBE,WARDRBS
- S NMSSN=GMTSPNM_" "_GMTSSN,NMSSNE=$L(NMSSN)+2,WARDRB=GMTSWARD_" "_GMTSRB
- S LWARDRB=$L(WARDRB),WARDRBS=40-(LWARDRB/2),WARDRBE=WARDRBS+LWARDRB
- S DOB="DOB: "_GMTSDOB,GMTSPHDR("NMSSN")=NMSSN,GMTSPHDR("WARDRB")=WARDRB
- S GMTSPHDR("WARDRBS")=WARDRBS,GMTSPHDR("DOB")=DOB,GMTSPHDR("DOBS")=64
- I (NMSSNE'<WARDRBS)!(WARDRBE'<64) S GMTSPHDR("TWO")=1
- Q
- ;
- NAME(X,Y,L) ; Format name
- ;
- ; Input
- ; X Internal Entry Number of NEW PERSON file 200
- ; Y Flag to specify the first name format
- ; 0 for First Name Initial (only)
- ; 1 for First Name
- ; L Maximum Length of Name
- ;
- ; Output Last,First (name/initial) to specified length
- ;
- N RAWNM,LAST,FIRST,ALPHA,PSN,CH,IEN,FNF,LEN
- S IEN=+($G(X)),FNF=+($G(Y)),LEN=+($G(L))
- S RAWNM=$$UNAM^GMTSU2(+IEN) S:LEN=0 LEN=$L(RAWNM)
- S RAWNM=$S($L(RAWNM):RAWNM,1:"UNKNOWN")
- S LAST=$P(RAWNM,","),FIRST=$P(RAWNM,",",2),ALPHA=0
- I $L(FIRST) D
- . F PSN=1:1 S CH=$E(FIRST,PSN) Q:CH="" S:CH?1A ALPHA=PSN Q:ALPHA>0
- S:ALPHA>0 FIRST=$E(FIRST,ALPHA,$L(FIRST))
- S:'FNF FIRST=$E(FIRST,1)
- S X=$S($L(FIRST):LAST_","_FIRST,1:LAST),X=$E(X,1,LEN)
- Q X
- GETRANGE(FROMDATE,TODATE) ; Select Date Range (from and to dates)
- N DIR,X,Y,DIROUT,DUOUT,DTOUT,DIRUT S DIR(0)="DO^:DT",DIR("A")="Enter Beginning Date (MM/DD/YY)" W !
- D ^DIR I $D(DIROUT)!$D(DUOUT)!$D(DTOUT)!$D(DIRUT) W ! Q
- S FROMDATE=Y I +FROMDATE>0 D
- . W " (",$$UP^XLFSTR($$FMTE^XLFDT(+FROMDATE,1)),")"
- . N DIR,X,Y S DIR(0)="DO^::EX",DIR("A")="Enter Ending Date (MM/DD/YY)" S DIR("B")="TODAY"
- . D ^DIR I $D(DIROUT)!$D(DUOUT)!$D(DTOUT)!$D(DIRUT) K FROMDATE Q
- . I Y'>0 K FROMDATE Q
- . S TODATE=Y Q:TODATE>FROMDATE!(TODATE=FROMDATE)
- . N FRDT S FRDT=FROMDATE,FROMDATE=TODATE,TODATE=FRDT
- W !
- Q
- ;
- OED() ; Other Editor - DIC("S")
- N COMP,OTHER,OWNER,OWNN,USER,AUSER,NAT S COMP=+($G(DA(1))) Q:'$D(^GMT(142,+COMP,0)) 0
- S OWNER=$P($G(^GMT(142,+COMP,0)),"^",3),OWNN=$$UNAM^GMTSU2(OWNER),NAT=+($P($G(^GMT(142,+COMP,"VA")),"^",1)),USER=+($G(DUZ)),AUSER=$$UACT^GMTSU2(+USER),OTHER=+($G(X))
- ; If National Component and Uneditable
- W:+NAT=2 !!," Nationally exported Health Summary Type (uneditable)",! Q:+NAT=2 0
- ; If OWNER is special case (national, uneditable)
- W:+OWNER>0&(OWNER<1)&(NAT'=1) !!," OWNER does not allow 'OTHER EDITORS'",! Q:+OWNER>0&(OWNER<1)&(NAT'=1) 0
- ; If OWNER is special case (national, editable)
- Q:+OWNER>0&(OWNER<1)&(OWNER=USER)&(NAT=1) 1
- ; If DUZ is inactive, or not the owner, quit
- W:+AUSER=0!(+OWNER=0)!(+OWNER'=+USER) !!," Only the OWNER may assign 'OTHER EDITORS'",! Q:+AUSER=0!(+OWNER=0)!(+OWNER'=+USER) 0
- ; If OTHER is inactive user, quit
- S AUSER=$$UACT^GMTSU2(OTHER) W:+AUSER=0!(+OTHER'>.999999999) !!," Selected 'OTHER EDITOR' is not an active user",! Q:+AUSER=0!(+OTHER'>.999999999) 0
- ; If OTHER=OWNER, quit
- W:+OTHER=+OWNER !!," ",OWNN," is the OWNER",! Q:+OTHER=+OWNER 0
- Q 1
- ;
- FCLR(X) ; File Closed Root
- S X=$G(X) Q:+X=0 "" N GMTSL S GMTSL=$$FLOC(X),X=$S($E(GMTSL,$L(GMTSL))=",":$P(GMTSL,",")_")",1:$E(GMTSL,1,$L(GMTSL)-1)) Q:'$L(X) "" S:'$D(@X) X=""
- Q X
- FSFN(X) ; File/Sub-File Name
- N FI,FR,%X,%Y S FI=$G(X) Q:+X=0 "" N DIERR,GMTSN,GMTSE D FILE^DID(+FI,"N","NAME","GMTSN","GMTSE")
- S X="" S:'$D(DIERR) X=$$UP^XLFSTR($G(GMTSN("NAME"))) Q:$L(X) X
- K FR S %X="^DD("_+($G(FI))_",0,""NM"",",%Y="FR(" D %XY^%RCR S X=$$UP^XLFSTR($O(FR(""))) S:+X>0 X="" S:$L(X) X=X_" SUB-FILE" Q X
- FNAM(X) ; File Name
- S X=$G(X) Q:+X=0 "" N DIERR,GMTSN,GMTSE D FILE^DID(+X,"N","NAME","GMTSN","GMTSE") S X="" S:'$D(DIERR) X=$G(GMTSN("NAME")) Q X
- FLOC(X) ; File location
- S X=$G(X) Q:+X=0 "" N DIERR,GMTSN,GMTSE D FILE^DID(+X,"N","GLOBAL NAME","GMTSN","GMTSE") S X="" S:'$D(DIERR) X=$G(GMTSN("GLOBAL NAME")) Q X
- FHDD(X) ; File has a DD?
- S X=+($G(X)) Q:+($G(X))=0 0 S X=$$VFIELD^DILFD(X,.01),X=$S($L(X):1,1:0) Q X
- FLDN(X,Y) ; Field Name
- Q:+($G(X))=0!(+($G(Y))=0) "" S X=$$GET1^DID(+($G(X)),+($G(Y)),,"LABEL") Q X
- FLDS(X,Y) ; Field Set of Codes
- Q:+($G(X))=0!(+($G(Y))=0) "" Q:$$GET1^DID(+($G(X)),+($G(Y)),,"TYPE")'="SET" "" S X=$$GET1^DID(+($G(X)),+($G(Y)),,"POINTER") Q X
- FLDI(X,Y) ; Field Input Transform
- Q:+($G(X))=0!(+($G(Y))=0) "" S X=$$GET1^DID(+($G(X)),+($G(Y)),,"INPUT TRANSFORM") Q X
- FORMAT(X,GMTSLABEL,DIWL) ; Format long line(s)
- N DIWR,DIWF,GMTSLCNT,GMTSLINE
- S DIWR=79,DIWF=""
- I $G(GMTSLABEL)'="" D
- .S GMTSINDENT=$L(GMTSLABEL)+2,GMTSLCNT=0
- .K ^UTILITY($J,"W")
- .S X=GMTSLABEL_": "_X
- E S DIWF="I"_+$G(GMTSINDENT),GMTSLCNT=+$G(^UTILITY($J,"W",DIWL))
- D ^DIWP
- I $G(GMTSLABEL)'="",$G(^UTILITY($J,"W",DIWL))>1 D
- .K ^TMP("GMTSTEXT",$J)
- .S GMTSLINE=1 F S GMTSLINE=$O(^UTILITY($J,"W",DIWL,GMTSLINE)) Q:'+GMTSLINE D
- ..S ^TMP("GMTSTEXT",$J,GMTSLINE)=^UTILITY($J,"W",DIWL,GMTSLINE,0)
- ..S ^UTILITY($J,"W",DIWL,GMTSLINE,0)=""
- .S DIWF="I"_GMTSINDENT,^UTILITY($J,"W",DIWL)=2
- .S GMTSLINE=0 F S GMTSLINE=$O(^TMP("GMTSTEXT",$J,GMTSLINE)) Q:'+GMTSLINE D
- ..S X=^TMP("GMTSTEXT",$J,GMTSLINE)
- ..D ^DIWP
- .K ^TMP("GMTSTEXT",$J)
- Q
- ;
- LINE(GMTSCOL) ; Writes wrapped long lines
- N GMTSSUB,GMTSLINE
- S GMTSCOL=$G(GMTSCOL,0)
- S GMTSSUB=$O(^UTILITY($J,"W",""))
- I GMTSSUB="" K GMTSINDENT,^UTILITY($J,"W") Q
- S GMTSLINE=0 F S GMTSLINE=$O(^UTILITY($J,"W",GMTSSUB,GMTSLINE)) Q:'+GMTSLINE!($D(GMTSQIT)) D
- .D CKP^GMTSUP Q:$D(GMTSQIT)
- .W !,?GMTSCOL,$$TRIM^XLFSTR(^UTILITY($J,"W",GMTSSUB,GMTSLINE,0),"R")
- K GMTSINDENT,^UTILITY($J,"W")
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSU 9915 printed Jan 18, 2025@03:01:36 Page 2
- GMTSU ;SLC/JER,KER - Health Summary Utilities ;Jul 21, 2023@12:36
- +1 ;;2.7;Health Summary;**27,28,31,35,37,43,47,56,144**;Oct 20, 1995;Build 17
- +2 ;
- +3 ; External References
- +4 ; DBIA 10096 ^%ZOSF("TEST")
- +5 ; DBIA 2934 ^A7RCP (NDBI Global)
- +6 ; DBIA 10103 $$FMTE^XLFDT
- +7 ; DBIA 10103 $$FMTHL7^XLFDT
- +8 ; DBIA 10103 $$HL7TFM^XLFDT
- +9 ; DBIA 10061 OERR^VADPT
- +10 ; DBIA 10104 $$UP^XLFSTR
- +11 ; DBIA 10026 ^DIR
- +12 ; DBIA 2052 FILE^DID
- +13 ; DBIA 10022 %XY^%RCR
- +14 ; DBIA 2055 $$VFIELD^DILFD
- +15 ; DBIA 2052 $$GET1^DID
- +16 ;
- PROK(X,Y) ; Routine and Patch # OK (in UCI)
- +1 NEW GMTS,GMTSI,GMTSO
- SET X=$GET(X)
- SET Y=$GET(Y)
- if '$LENGTH(X)
- QUIT 0
- if Y'=""&(+Y=0)
- QUIT
- +2 SET Y=+Y
- SET GMTS=$$ROK(X)
- if 'GMTS
- QUIT 0
- if +Y=0
- QUIT 1
- SET GMTSO=0
- SET GMTS=$TEXT(@("+2^"_X))
- SET GMTS=$PIECE($PIECE(GMTS,"**",2),"**",1)
- +3 FOR GMTSI=1:1:$LENGTH(GMTS,",")
- if +($PIECE(GMTS,",",GMTSI))=Y
- SET GMTSO=1
- if GMTSO=1
- QUIT
- +4 SET X=GMTSO
- QUIT X
- ROK(X) ; Routine OK (in UCI) (NDBI)
- +1 SET X=$GET(X)
- if '$LENGTH(X)
- QUIT 0
- if $LENGTH(X)>8
- QUIT 0
- XECUTE ^%ZOSF("TEST")
- if $TEST
- QUIT 1
- QUIT 0
- NDBI(X) ; National Database Integration site 1 = yes 0 = no
- +1 NEW R,G
- SET X="A7RDUP"
- XECUTE ^%ZOSF("TEST")
- SET R=$TEST
- SET G=$SELECT($DATA(^A7RCP):1,1:0)
- SET X=R+G
- SET X=$SELECT(X=2:1,1:0)
- QUIT X
- +2 ;
- CPT(X) ; Use CPT Modifiers Needs GMTSEG Array
- +1 SET X=+($GET(X))
- NEW GMTSN,GMTSC,GMTSM,GMTSA,GMTSI
- SET GMTSN=$GET(GMTSEG(X))
- SET GMTSC=+($PIECE(GMTSN,"^",2))
- if 'GMTSC
- QUIT 0
- +2 SET GMTSM=$SELECT($PIECE(GMTSN,"^",9)="N":0,$PIECE(GMTSN,"^",9)="":1,1:1)
- if 'GMTSM
- QUIT 0
- +3 SET GMTSA=$SELECT(+($$CMU(+GMTSC))>0:1,1:0)
- if 'GMTSA
- QUIT 0
- +4 QUIT 1
- CMU(X) ; Component Uses CPT Modifiers
- +1 NEW GMTSA,GMTSN,GMTSI
- SET X=$GET(X)
- if '$LENGTH(X)
- QUIT 0
- SET GMTSI=+X
- SET GMTSA=$ORDER(^GMT(142.1,"C",X,0))
- SET GMTSN=$ORDER(^GMT(142.1,"D",X,0))
- if GMTSI=0&(+GMTSA>0)
- SET GMTSI=GMTSA
- if GMTSI=0&(+GMTSN>0)
- SET GMTSI=GMTSN
- +2 if +GMTSI=0
- QUIT 0
- SET GMTSA=$SELECT($PIECE($GET(^GMT(142.1,+GMTSI,0)),"^",14)="Y":1,1:0)
- if 'GMTSA
- QUIT 0
- +3 QUIT 1
- +4 ;
- +5 ; Dates and Time
- ED(X) ; Health Summary External Date
- +1 SET X=$GET(X)
- if '$LENGTH(X)
- QUIT ""
- DO REGDT4
- QUIT X
- EDT(X) ; Health Summary External Date and Time
- +1 SET X=$GET(X)
- if '$LENGTH(X)
- QUIT ""
- DO REGDTM4
- QUIT X
- REGDT ; Receives X FM date and returns X in MM/DD/YY format
- +1 SET X=$TRANSLATE($$FMTE^XLFDT(X,"2DZ"),"@"," ")
- QUIT
- REGDT4 ; Receives X FM date and returns X in MM/DD/YYYY format
- +1 SET X=$TRANSLATE($$FMTE^XLFDT(X,"5DZ"),"@"," ")
- QUIT
- REGDTM ; Receives X FM date and returns X in MM/DD/YY TT:TT
- +1 SET X=$TRANSLATE($$FMTE^XLFDT(X,"2ZM"),"@"," ")
- QUIT
- REGDTM4 ; Receives X FM date and returns X in MM/DD/YYYY TT:TT
- +1 SET X=$TRANSLATE($$FMTE^XLFDT(X,"5ZM"),"@"," ")
- QUIT
- SIDT ; Receives X FM date and returns X in DD MMM YY
- +1 NEW MON,MM
- SET X=$PIECE(X,".")
- if 'X
- SET X=""
- if '$LENGTH(X)
- QUIT
- +2 SET MON="JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC"
- +3 SET MM=$EXTRACT(X,4,5)
- SET MM=$SELECT(MM:$PIECE(MON,U,+MM),1:"")
- +4 SET X=$EXTRACT(X,6,7)_" "_MM_" "_$EXTRACT(X,2,3)
- QUIT
- MTIM ; Convert Time from X=2890313.1304 to X=13:04
- +1 SET X=$PIECE(X,".",2)
- if '$LENGTH(X)
- QUIT
- SET X=$SELECT(X:$EXTRACT(X,1,2)_$EXTRACT("00",0,2-$LENGTH($EXTRACT(X,1,2)))_":"_$EXTRACT(X,3,4)_$EXTRACT("00",0,2-$LENGTH($EXTRACT(X,3,4))),1:"")
- +2 QUIT
- +3 ;
- HF(X) ; Host File - Used to distinguish from Host Files that
- +1 ; are intended for Printers and Host Files for other
- +2 ; purposes (windows/files)
- +3 ;
- +4 ; 1 - if Device Type is HFS and not a TCP/IP Printer
- +5 ; 0 - if Device Type is not HFS or device is a Printer
- +6 ;
- +7 ; Check Device
- +8 ; Check Host File Server
- +9 if $GET(IOT)'="HFS"
- QUIT 0
- +10 ; Check ORWINDEV (Post OR*3.0*85)
- +11 NEW GMTS85
- SET GMTS85=$$PROK("ORWRP",85)
- +12 if +($GET(GMTS85))>0&(+($GET(ORWINDEV))>0)
- QUIT 0
- +13 ; Host File for GUI Scrollable Window
- +14 if $EXTRACT($GET(ION),1,14)["OR WORKSTATION"
- QUIT 1
- +15 ; TCP/IP Printer
- +16 if $GET(IO)["$PRT"!($GET(IO)["PRN|")
- QUIT 0
- +17 ; Windows Printer
- +18 if $EXTRACT($GET(ION),1,14)["OR WINDOWS HFS"
- QUIT 0
- +19 ; Host Files (file or unspecifed printer)
- +20 SET X=0
- if $GET(ION)["HOST FILE"
- SET X=1
- +21 if $EXTRACT($GET(IOST),1,5)["P-OTH"
- SET X=1
- +22 QUIT X
- +23 ;
- FMHL7DTM ; Convert X - int date/time to HL7 CCYYMMDDHHMM-HHHH
- +1 SET X=$$FMTHL7^XLFDT(+($GET(X)))
- QUIT
- HL7FMDTM ; Convert X - HL7 CCYYMMDDHHMM-HHHH to int date/time local
- +1 SET X=$$HL7TFM^XLFDT($GET(X),"L")
- QUIT
- +2 ;
- DEM ; Gets Demographic Data from VADPT
- +1 ;
- +2 ; Input DFN
- +3 ;
- +4 ; Output GMTSPNM Patient Name
- +5 ; GMTSSN Social Security Number
- +6 ; GMTSDOB Date of Birth
- +7 ; SEX Sex
- +8 ; GMTSWARD Ward
- +9 ; GMTSRB Bed
- +10 ; GMTSAGE Age
- +11 ; VADM() Demographic Array
- +12 ; VAIN() Inpatient Array
- +13 ; GMTSPHDR() Report Header Array
- +14 ;
- +15 KILL VAHOW
- DO OERR^VADPT
- SET GMTSPNM=VADM(1)
- SET GMTSSN=$SELECT($DATA(VA("PID")):VA("PID"),1:$PIECE(VADM(2),"^",2))
- +16 SET GMTSAGE=$SELECT(+VADM(4)>0:+VADM(4),1:99)
- SET SEX=$PIECE(VADM(5),"^")
- +17 SET GMTSWARD=$PIECE(VAIN(4),"^",2)
- SET GMTSRB=VAIN(5)
- +18 SET X=$PIECE(VADM(3),"^")
- DO REGDT4
- SET GMTSDOB=X
- KILL VA,GMTSPHDR
- NEW DOB,LWARDRB,NMSSN,NMSSNE,WARDRB,WARDRBE,WARDRBS
- +19 SET NMSSN=GMTSPNM_" "_GMTSSN
- SET NMSSNE=$LENGTH(NMSSN)+2
- SET WARDRB=GMTSWARD_" "_GMTSRB
- +20 SET LWARDRB=$LENGTH(WARDRB)
- SET WARDRBS=40-(LWARDRB/2)
- SET WARDRBE=WARDRBS+LWARDRB
- +21 SET DOB="DOB: "_GMTSDOB
- SET GMTSPHDR("NMSSN")=NMSSN
- SET GMTSPHDR("WARDRB")=WARDRB
- +22 SET GMTSPHDR("WARDRBS")=WARDRBS
- SET GMTSPHDR("DOB")=DOB
- SET GMTSPHDR("DOBS")=64
- +23 IF (NMSSNE'<WARDRBS)!(WARDRBE'<64)
- SET GMTSPHDR("TWO")=1
- +24 QUIT
- +25 ;
- NAME(X,Y,L) ; Format name
- +1 ;
- +2 ; Input
- +3 ; X Internal Entry Number of NEW PERSON file 200
- +4 ; Y Flag to specify the first name format
- +5 ; 0 for First Name Initial (only)
- +6 ; 1 for First Name
- +7 ; L Maximum Length of Name
- +8 ;
- +9 ; Output Last,First (name/initial) to specified length
- +10 ;
- +11 NEW RAWNM,LAST,FIRST,ALPHA,PSN,CH,IEN,FNF,LEN
- +12 SET IEN=+($GET(X))
- SET FNF=+($GET(Y))
- SET LEN=+($GET(L))
- +13 SET RAWNM=$$UNAM^GMTSU2(+IEN)
- if LEN=0
- SET LEN=$LENGTH(RAWNM)
- +14 SET RAWNM=$SELECT($LENGTH(RAWNM):RAWNM,1:"UNKNOWN")
- +15 SET LAST=$PIECE(RAWNM,",")
- SET FIRST=$PIECE(RAWNM,",",2)
- SET ALPHA=0
- +16 IF $LENGTH(FIRST)
- Begin DoDot:1
- +17 FOR PSN=1:1
- SET CH=$EXTRACT(FIRST,PSN)
- if CH=""
- QUIT
- if CH?1A
- SET ALPHA=PSN
- if ALPHA>0
- QUIT
- End DoDot:1
- +18 if ALPHA>0
- SET FIRST=$EXTRACT(FIRST,ALPHA,$LENGTH(FIRST))
- +19 if 'FNF
- SET FIRST=$EXTRACT(FIRST,1)
- +20 SET X=$SELECT($LENGTH(FIRST):LAST_","_FIRST,1:LAST)
- SET X=$EXTRACT(X,1,LEN)
- +21 QUIT X
- GETRANGE(FROMDATE,TODATE) ; Select Date Range (from and to dates)
- +1 NEW DIR,X,Y,DIROUT,DUOUT,DTOUT,DIRUT
- SET DIR(0)="DO^:DT"
- SET DIR("A")="Enter Beginning Date (MM/DD/YY)"
- WRITE !
- +2 DO ^DIR
- IF $DATA(DIROUT)!$DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIRUT)
- WRITE !
- QUIT
- +3 SET FROMDATE=Y
- IF +FROMDATE>0
- Begin DoDot:1
- +4 WRITE " (",$$UP^XLFSTR($$FMTE^XLFDT(+FROMDATE,1)),")"
- +5 NEW DIR,X,Y
- SET DIR(0)="DO^::EX"
- SET DIR("A")="Enter Ending Date (MM/DD/YY)"
- SET DIR("B")="TODAY"
- +6 DO ^DIR
- IF $DATA(DIROUT)!$DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIRUT)
- KILL FROMDATE
- QUIT
- +7 IF Y'>0
- KILL FROMDATE
- QUIT
- +8 SET TODATE=Y
- if TODATE>FROMDATE!(TODATE=FROMDATE)
- QUIT
- +9 NEW FRDT
- SET FRDT=FROMDATE
- SET FROMDATE=TODATE
- SET TODATE=FRDT
- End DoDot:1
- +10 WRITE !
- +11 QUIT
- +12 ;
- OED() ; Other Editor - DIC("S")
- +1 NEW COMP,OTHER,OWNER,OWNN,USER,AUSER,NAT
- SET COMP=+($GET(DA(1)))
- if '$DATA(^GMT(142,+COMP,0))
- QUIT 0
- +2 SET OWNER=$PIECE($GET(^GMT(142,+COMP,0)),"^",3)
- SET OWNN=$$UNAM^GMTSU2(OWNER)
- SET NAT=+($PIECE($GET(^GMT(142,+COMP,"VA")),"^",1))
- SET USER=+($GET(DUZ))
- SET AUSER=$$UACT^GMTSU2(+USER)
- SET OTHER=+($GET(X))
- +3 ; If National Component and Uneditable
- +4 if +NAT=2
- WRITE !!," Nationally exported Health Summary Type (uneditable)",!
- if +NAT=2
- QUIT 0
- +5 ; If OWNER is special case (national, uneditable)
- +6 if +OWNER>0&(OWNER<1)&(NAT'=1)
- WRITE !!," OWNER does not allow 'OTHER EDITORS'",!
- if +OWNER>0&(OWNER<1)&(NAT'=1)
- QUIT 0
- +7 ; If OWNER is special case (national, editable)
- +8 if +OWNER>0&(OWNER<1)&(OWNER=USER)&(NAT=1)
- QUIT 1
- +9 ; If DUZ is inactive, or not the owner, quit
- +10 if +AUSER=0!(+OWNER=0)!(+OWNER'=+USER)
- WRITE !!," Only the OWNER may assign 'OTHER EDITORS'",!
- if +AUSER=0!(+OWNER=0)!(+OWNER'=+USER)
- QUIT 0
- +11 ; If OTHER is inactive user, quit
- +12 SET AUSER=$$UACT^GMTSU2(OTHER)
- if +AUSER=0!(+OTHER'>.999999999)
- WRITE !!," Selected 'OTHER EDITOR' is not an active user",!
- if +AUSER=0!(+OTHER'>.999999999)
- QUIT 0
- +13 ; If OTHER=OWNER, quit
- +14 if +OTHER=+OWNER
- WRITE !!," ",OWNN," is the OWNER",!
- if +OTHER=+OWNER
- QUIT 0
- +15 QUIT 1
- +16 ;
- FCLR(X) ; File Closed Root
- +1 SET X=$GET(X)
- if +X=0
- QUIT ""
- NEW GMTSL
- SET GMTSL=$$FLOC(X)
- SET X=$SELECT($EXTRACT(GMTSL,$LENGTH(GMTSL))=",":$PIECE(GMTSL,",")_")",1:$EXTRACT(GMTSL,1,$LENGTH(GMTSL)-1))
- if '$LENGTH(X)
- QUIT ""
- if '$DATA(@X)
- SET X=""
- +2 QUIT X
- FSFN(X) ; File/Sub-File Name
- +1 NEW FI,FR,%X,%Y
- SET FI=$GET(X)
- if +X=0
- QUIT ""
- NEW DIERR,GMTSN,GMTSE
- DO FILE^DID(+FI,"N","NAME","GMTSN","GMTSE")
- +2 SET X=""
- if '$DATA(DIERR)
- SET X=$$UP^XLFSTR($GET(GMTSN("NAME")))
- if $LENGTH(X)
- QUIT X
- +3 KILL FR
- SET %X="^DD("_+($GET(FI))_",0,""NM"","
- SET %Y="FR("
- DO %XY^%RCR
- SET X=$$UP^XLFSTR($ORDER(FR("")))
- if +X>0
- SET X=""
- if $LENGTH(X)
- SET X=X_" SUB-FILE"
- QUIT X
- FNAM(X) ; File Name
- +1 SET X=$GET(X)
- if +X=0
- QUIT ""
- NEW DIERR,GMTSN,GMTSE
- DO FILE^DID(+X,"N","NAME","GMTSN","GMTSE")
- SET X=""
- if '$DATA(DIERR)
- SET X=$GET(GMTSN("NAME"))
- QUIT X
- FLOC(X) ; File location
- +1 SET X=$GET(X)
- if +X=0
- QUIT ""
- NEW DIERR,GMTSN,GMTSE
- DO FILE^DID(+X,"N","GLOBAL NAME","GMTSN","GMTSE")
- SET X=""
- if '$DATA(DIERR)
- SET X=$GET(GMTSN("GLOBAL NAME"))
- QUIT X
- FHDD(X) ; File has a DD?
- +1 SET X=+($GET(X))
- if +($GET(X))=0
- QUIT 0
- SET X=$$VFIELD^DILFD(X,.01)
- SET X=$SELECT($LENGTH(X):1,1:0)
- QUIT X
- FLDN(X,Y) ; Field Name
- +1 if +($GET(X))=0!(+($GET(Y))=0)
- QUIT ""
- SET X=$$GET1^DID(+($GET(X)),+($GET(Y)),,"LABEL")
- QUIT X
- FLDS(X,Y) ; Field Set of Codes
- +1 if +($GET(X))=0!(+($GET(Y))=0)
- QUIT ""
- if $$GET1^DID(+($GET(X)),+($GET(Y)),,"TYPE")'="SET"
- QUIT ""
- SET X=$$GET1^DID(+($GET(X)),+($GET(Y)),,"POINTER")
- QUIT X
- FLDI(X,Y) ; Field Input Transform
- +1 if +($GET(X))=0!(+($GET(Y))=0)
- QUIT ""
- SET X=$$GET1^DID(+($GET(X)),+($GET(Y)),,"INPUT TRANSFORM")
- QUIT X
- FORMAT(X,GMTSLABEL,DIWL) ; Format long line(s)
- +1 NEW DIWR,DIWF,GMTSLCNT,GMTSLINE
- +2 SET DIWR=79
- SET DIWF=""
- +3 IF $GET(GMTSLABEL)'=""
- Begin DoDot:1
- +4 SET GMTSINDENT=$LENGTH(GMTSLABEL)+2
- SET GMTSLCNT=0
- +5 KILL ^UTILITY($JOB,"W")
- +6 SET X=GMTSLABEL_": "_X
- End DoDot:1
- +7 IF '$TEST
- SET DIWF="I"_+$GET(GMTSINDENT)
- SET GMTSLCNT=+$GET(^UTILITY($JOB,"W",DIWL))
- +8 DO ^DIWP
- +9 IF $GET(GMTSLABEL)'=""
- IF $GET(^UTILITY($JOB,"W",DIWL))>1
- Begin DoDot:1
- +10 KILL ^TMP("GMTSTEXT",$JOB)
- +11 SET GMTSLINE=1
- FOR
- SET GMTSLINE=$ORDER(^UTILITY($JOB,"W",DIWL,GMTSLINE))
- if '+GMTSLINE
- QUIT
- Begin DoDot:2
- +12 SET ^TMP("GMTSTEXT",$JOB,GMTSLINE)=^UTILITY($JOB,"W",DIWL,GMTSLINE,0)
- +13 SET ^UTILITY($JOB,"W",DIWL,GMTSLINE,0)=""
- End DoDot:2
- +14 SET DIWF="I"_GMTSINDENT
- SET ^UTILITY($JOB,"W",DIWL)=2
- +15 SET GMTSLINE=0
- FOR
- SET GMTSLINE=$ORDER(^TMP("GMTSTEXT",$JOB,GMTSLINE))
- if '+GMTSLINE
- QUIT
- Begin DoDot:2
- +16 SET X=^TMP("GMTSTEXT",$JOB,GMTSLINE)
- +17 DO ^DIWP
- End DoDot:2
- +18 KILL ^TMP("GMTSTEXT",$JOB)
- End DoDot:1
- +19 QUIT
- +20 ;
- LINE(GMTSCOL) ; Writes wrapped long lines
- +1 NEW GMTSSUB,GMTSLINE
- +2 SET GMTSCOL=$GET(GMTSCOL,0)
- +3 SET GMTSSUB=$ORDER(^UTILITY($JOB,"W",""))
- +4 IF GMTSSUB=""
- KILL GMTSINDENT,^UTILITY($JOB,"W")
- QUIT
- +5 SET GMTSLINE=0
- FOR
- SET GMTSLINE=$ORDER(^UTILITY($JOB,"W",GMTSSUB,GMTSLINE))
- if '+GMTSLINE!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:1
- +6 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- +7 WRITE !,?GMTSCOL,$$TRIM^XLFSTR(^UTILITY($JOB,"W",GMTSSUB,GMTSLINE,0),"R")
- End DoDot:1
- +8 KILL GMTSINDENT,^UTILITY($JOB,"W")
- +9 QUIT
- +10 ;