DGUTL ;ALB/MRL - DG UTILITY FUNCTIONS ; 08 JAN 86
;;5.3;Registration;**279,570,677**;Aug 13, 1993
;
RI ;Reimbursable Insurance
; ** NOTE: This procedure appears to be obsolete, but code was modified
; for IB/AR Encapsulation anyways.
S DGINS=$$INSUR^IBBAPI(DFN,"","A")
Q
;
TS ;Table of Contents SET
I '$D(^UTILITY($J,"DGTC",DGPAG)) S ^UTILITY($J,"DGTC",DGPAG,DGPAG1)="" Q
TP ;Table of Contents PRINT
I '$D(^UTILITY($J,"DGTC")) Q
D TH S J=0 F I=0:0 S J=$O(^UTILITY($J,"DGTC",J)),J1=0 Q:J="" F I1=0:0 S J1=$O(^UTILITY($J,"DGTC",J,J1)) Q:J1="" S X="",$P(X,".",(IOM-20-$L(J)-$L(J1)))="" W !?10,J," ",X," ",J1 I $Y>$S($D(IOSL):(IOSL-6),1:62) D TH
W ! K ^UTILITY($J,"DGTC"),I,I1,J,J1,DGTCH,X,Y Q
TH ;Table of Contents HEADER
W @IOF,!,"TABLE OF CONTENTS FOR '",$P(DGTCH,U,1),"'",?(IOM-11) S Y=DT X ^DD("DD") W Y,!?10,$P(DGTCH,U,2),?IOM-7-$L($P(DGTCH,U,3)),$P(DGTCH,U,3) S X="",$P(X,"=",IOM)="" W !,X K X Q
C ;Cover Page
W @IOF S TT=0 F I=0:0 S I=$O(DGCPG(I)) Q:'I S TT=TT+1,$P(DGCPG(I),U,2)=$S($D(IOM):IOM-$L($P(DGCPG(I),U,1))\2,1:132-$L($P(DGCPG(I),U,1))\2)
S TT=$S($D(IOSL):IOSL-(TT*2+10)\2,1:66-(TT*2+10)\2) F I=1:1:TT W !
F I=0:0 S I=$O(DGCPG(I)) Q:'I W !!?$P(DGCPG(I),U,2),$P(DGCPG(I),U,1)
I $D(DUZ),$D(^VA(200,+DUZ,0)) S X="Printed by: "_$P(^(0),U,1),X1=$S($D(IOM):IOM-$L(X)\2,1:132-$L(X)\2) W !!?X1,X
I $D(^DD("SITE"))#2 S X=^("SITE")_" ("_^("SITE",1)_")",X1=$S($D(IOM):IOM-$L(X)\2,1:132-$L(X)\2) W !!?X1,X
I $D(DGCPT) X "F I=1:1:$S($D(IOSL):(IOSL-5),1:61)-$Y W !" W DGCPT
W !! K TT,I,X,X1 Q
H ;Convert $H to Readable Date/Time
D:'$D(DT) DT^DICRW S DGTIME=$P($H,",",2),DGTIME=DT+(DGTIME\3600/100)+(DGTIME\60#60/10000),DGDATE=DGTIME\1 Q
DIV ;Determine Division
I $D(^DG(43,1,"GL")),$P(^("GL"),"^",2) S DGDIV="" Q
S DGDIV=$S($O(^DG(40.8,0))>0:$O(^DG(40.8,0)),1:"") I DGDIV S DGDIV=DGDIV_"^"_$P(^DG(40.8,+DGDIV,0),"^",1)
Q
DT W:$E(%,4,5) +$E(%,4,5)_"-" W:$E(%,6,7) +$E(%,6,7)_"-" W $E(%,1,3)+1700 W:%["." " ("_$E(%_0,9,10)_":"_$E(%_"000",11,12)_")" Q
EOM ;Required Variable: X - Date should be in internal FM date format
;Returned Variable: Y - End of Month in internal FM date format
S X1=$S($E(X,4,5)=12:$E(X,1,3)+1_"01",1:$E(X,1,5)+1)_"01"_$S($P(X,".",2):"."_$P(X,".",2),1:""),X2=-1 D C^%DTC S Y=X K X
Q
LO D:'$D(DT) DT^DICRW S:'$D(DTIME) DTIME=300 S U="^" Q
I '$D(^DG(43,1,0)) W !,"ADT parameters not set up",*7 G H^XUS
S USER=$S($D(DUZ)#10:DUZ,1:0) I 'USER!('$D(^VA(200,USER,0))) W !!,"Please log off the computer and then back to use this option.",!!,*7 K ^UTILITY("DG",$J) G H^XUS
K USER Q
;
UPPER(X) ; -- convert to uppercase
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
LOWER(X) ;
N Y,C,Z,I
S Y=$E(X)_$TR($E(X,2,999),"ABCDEFGHIJKLMNOPQRSTUVWXYZ@","abcdefghijklmnopqrstuvwxyz ")
F C=" ",",","/" F I=2:1 S Z=$P(Y,C,I,999) Q:Z="" S Y=$P(Y,C,1,I-1)_C_$TR($E(Z),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$E(Z,2,999)
Q Y
QUES(DFN,DGQCODE) ; EDIT REGISTRATION DATA FOR AMIE USE ONLY
;
; INPUT:
; DFN
; DGQCODE = Code for question(s) to be asked
; OUTPUT:
; DGERR = ERROR VARIABLE
; DGCHANGE= 1 IF DATA MODIFIED 0 O/W
;
N D,D0,DI,DIC,DGCODE,DGDR,DGNODE,DGQNODES,DGPC,DGPTND,DGRPS,DGQ,DGX,DQ,N,X,Y,%Y
S (DGERR,DGRPS,DGCHANGE)=0
G:'($G(DFN)&($G(DGQCODE)="ADD1")) QTE
S DGPC=2,DGCODE="ADD1"
S DGDR=104
S DGRPS=1
S DGQNODES=".11~.13"
F N=1:1 S DGNODE=$P(DGQNODES,"~",N) Q:DGNODE']"" S DGPTND(DGNODE)=$G(^DPT(DFN,DGNODE))
D ^DGRPE
F DGNODE=0:0 S DGNODE=$O(DGPTND(DGNODE)) Q:DGNODE']"" S:$G(^DPT(DFN,DGNODE))'=(DGPTND(DGNODE)) DGCHANGE=1
QTE I 'DGRPS S DGERR=1
QTQ Q
;FORM FEED & STOPPING UTILITIES
FIRST() ;First heading of report
; RETURNS STOP; 0=GO,1=STOP
N STOP
D STOPCHK
D:$G(STOP) STOPPED
I '$G(STOP),$E($G(IOST),1,2)="C-" W @IOF
Q $G(STOP)
;
SUBSEQ() ;enter for further headings of report
; RETURNS STOP; 0=GO,1=STOP
N STOP,DIR,X,Y
D STOPCHK
I $E($G(IOST),1,2)="C-" S DIR(0)="E" D ^DIR S:$D(DIRUT) STOP=1
D:$G(STOP) STOPPED
I '$G(STOP) W @IOF
Q $G(STOP)
;
STOPCHK I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,STOP)=1
Q
STOPPED ;
W !?5,"------------- Report stopped at user's request ------------"
K ZTREQ
Q
ENDREP I $E(IOST,1,2)'["C-" W:$Y&'$D(IONOFF) @IOF Q
Q
;
ASKDIV(NOTALL) ;Ask for division (one/many/all)
; Input: NOTALL - Flag that prevents selection of all divisions
; 1 = Don't allow selection of all divisions
; 0 = Allow selection of all divisions (default)
;Output: Integer indicating if selection was made
; 0 = No divisions selected (user quit)
; 1 = Divisions selected
; VAUTD will be set as follows:
; VAUTD = 1 if all divisions selected
; VAUTD = 0 if individual divisions selected
; VAUTD(DivPtr) = DivisionName for each division selected
; Notes: VAUTD is KILLed in input
;
N FIRSTDIV,MULTIDIV,Y,VAUTNALL
K VAUTD
S FIRSTDIV=+$O(^DG(40.80,0))
I '$D(^DG(40.8,FIRSTDIV,0)) D G ASKDIVQ
. W !
. W $C(7),"***WARNING...MEDICAL CENTER DIVISION FILE IS NOT SET UP***"
. W !
S MULTIDIV=+$P($G(^DG(43,1,"GL")),"^",2)
I 'MULTIDIV S VAUTD=1 G ASKDIVQ
S (VAUTD,Y)=0
I +$G(NOTALL) S VAUTNALL=1
D DIVISION^VAUTOMA
I Y<0 K VAUTD
ASKDIVQ Q $D(VAUTD)>0
;
EMGRES(DFN) ;DG*5.3*677
;This API returns the value of the Emergency Response
;Indicator (file 2, field .181), or null if blank
;
;INPUT:
; DFN - pointer to the Patient File (#2)
;
;OUTPUT:
; Function value - returns value from E.R.I. field, or null if blank
;
I 'DFN Q ""
;
N RESULT
S RESULT=$P($G(^DPT(DFN,.18)),U)
Q RESULT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGUTL 5679 printed Oct 16, 2024@18:59:38 Page 2
DGUTL ;ALB/MRL - DG UTILITY FUNCTIONS ; 08 JAN 86
+1 ;;5.3;Registration;**279,570,677**;Aug 13, 1993
+2 ;
RI ;Reimbursable Insurance
+1 ; ** NOTE: This procedure appears to be obsolete, but code was modified
+2 ; for IB/AR Encapsulation anyways.
+3 SET DGINS=$$INSUR^IBBAPI(DFN,"","A")
+4 QUIT
+5 ;
TS ;Table of Contents SET
+1 IF '$DATA(^UTILITY($JOB,"DGTC",DGPAG))
SET ^UTILITY($JOB,"DGTC",DGPAG,DGPAG1)=""
QUIT
TP ;Table of Contents PRINT
+1 IF '$DATA(^UTILITY($JOB,"DGTC"))
QUIT
+2 DO TH
SET J=0
FOR I=0:0
SET J=$ORDER(^UTILITY($JOB,"DGTC",J))
SET J1=0
if J=""
QUIT
FOR I1=0:0
SET J1=$ORDER(^UTILITY($JOB,"DGTC",J,J1))
if J1=""
QUIT
SET X=""
SET $PIECE(X,".",(IOM-20-$LENGTH(J)-$LENGTH(J1)))=""
WRITE !?10,J," ",X," ",J1
IF $Y>$SELECT($DATA(IOSL):(IOSL-6),1:62)
DO TH
+3 WRITE !
KILL ^UTILITY($JOB,"DGTC"),I,I1,J,J1,DGTCH,X,Y
QUIT
TH ;Table of Contents HEADER
+1 WRITE @IOF,!,"TABLE OF CONTENTS FOR '",$PIECE(DGTCH,U,1),"'",?(IOM-11)
SET Y=DT
XECUTE ^DD("DD")
WRITE Y,!?10,$PIECE(DGTCH,U,2),?IOM-7-$LENGTH($PIECE(DGTCH,U,3)),$PIECE(DGTCH,U,3)
SET X=""
SET $PIECE(X,"=",IOM)=""
WRITE !,X
KILL X
QUIT
C ;Cover Page
+1 WRITE @IOF
SET TT=0
FOR I=0:0
SET I=$ORDER(DGCPG(I))
if 'I
QUIT
SET TT=TT+1
SET $PIECE(DGCPG(I),U,2)=$SELECT($DATA(IOM):IOM-$LENGTH($PIECE(DGCPG(I),U,1))\2,1:132-$LENGTH($PIECE(DGCPG(I),U,1))\2)
+2 SET TT=$SELECT($DATA(IOSL):IOSL-(TT*2+10)\2,1:66-(TT*2+10)\2)
FOR I=1:1:TT
WRITE !
+3 FOR I=0:0
SET I=$ORDER(DGCPG(I))
if 'I
QUIT
WRITE !!?$PIECE(DGCPG(I),U,2),$PIECE(DGCPG(I),U,1)
+4 IF $DATA(DUZ)
IF $DATA(^VA(200,+DUZ,0))
SET X="Printed by: "_$PIECE(^(0),U,1)
SET X1=$SELECT($DATA(IOM):IOM-$LENGTH(X)\2,1:132-$LENGTH(X)\2)
WRITE !!?X1,X
+5 IF $DATA(^DD("SITE"))#2
SET X=^("SITE")_" ("_^("SITE",1)_")"
SET X1=$SELECT($DATA(IOM):IOM-$LENGTH(X)\2,1:132-$LENGTH(X)\2)
WRITE !!?X1,X
+6 IF $DATA(DGCPT)
XECUTE "F I=1:1:$S($D(IOSL):(IOSL-5),1:61)-$Y W !"
WRITE DGCPT
+7 WRITE !!
KILL TT,I,X,X1
QUIT
H ;Convert $H to Readable Date/Time
+1 if '$DATA(DT)
DO DT^DICRW
SET DGTIME=$PIECE($HOROLOG,",",2)
SET DGTIME=DT+(DGTIME\3600/100)+(DGTIME\60#60/10000)
SET DGDATE=DGTIME\1
QUIT
DIV ;Determine Division
+1 IF $DATA(^DG(43,1,"GL"))
IF $PIECE(^("GL"),"^",2)
SET DGDIV=""
QUIT
+2 SET DGDIV=$SELECT($ORDER(^DG(40.8,0))>0:$ORDER(^DG(40.8,0)),1:"")
IF DGDIV
SET DGDIV=DGDIV_"^"_$PIECE(^DG(40.8,+DGDIV,0),"^",1)
+3 QUIT
DT if $EXTRACT(%,4,5)
WRITE +$EXTRACT(%,4,5)_"-"
if $EXTRACT(%,6,7)
WRITE +$EXTRACT(%,6,7)_"-"
WRITE $EXTRACT(%,1,3)+1700
if %["."
WRITE " ("_$EXTRACT(%_0,9,10)_":"_$EXTRACT(%_"000",11,12)_")"
QUIT
EOM ;Required Variable: X - Date should be in internal FM date format
+1 ;Returned Variable: Y - End of Month in internal FM date format
+2 SET X1=$SELECT($EXTRACT(X,4,5)=12:$EXTRACT(X,1,3)+1_"01",1:$EXTRACT(X,1,5)+1)_"01"_$SELECT($PIECE(X,".",2):"."_$PIECE(X,".",2),1:"")
SET X2=-1
DO C^%DTC
SET Y=X
KILL X
+3 QUIT
LO if '$DATA(DT)
DO DT^DICRW
if '$DATA(DTIME)
SET DTIME=300
SET U="^"
QUIT
+1 IF '$DATA(^DG(43,1,0))
WRITE !,"ADT parameters not set up",*7
GOTO H^XUS
+2 SET USER=$SELECT($DATA(DUZ)#10:DUZ,1:0)
IF 'USER!('$DATA(^VA(200,USER,0)))
WRITE !!,"Please log off the computer and then back to use this option.",!!,*7
KILL ^UTILITY("DG",$JOB)
GOTO H^XUS
+3 KILL USER
QUIT
+4 ;
UPPER(X) ; -- convert to uppercase
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
LOWER(X) ;
+1 NEW Y,C,Z,I
+2 SET Y=$EXTRACT(X)_$TRANSLATE($EXTRACT(X,2,999),"ABCDEFGHIJKLMNOPQRSTUVWXYZ@","abcdefghijklmnopqrstuvwxyz ")
+3 FOR C=" ",",","/"
FOR I=2:1
SET Z=$PIECE(Y,C,I,999)
if Z=""
QUIT
SET Y=$PIECE(Y,C,1,I-1)_C_$TRANSLATE($EXTRACT(Z),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$EXTRACT(Z,2,999)
+4 QUIT Y
QUES(DFN,DGQCODE) ; EDIT REGISTRATION DATA FOR AMIE USE ONLY
+1 ;
+2 ; INPUT:
+3 ; DFN
+4 ; DGQCODE = Code for question(s) to be asked
+5 ; OUTPUT:
+6 ; DGERR = ERROR VARIABLE
+7 ; DGCHANGE= 1 IF DATA MODIFIED 0 O/W
+8 ;
+9 NEW D,D0,DI,DIC,DGCODE,DGDR,DGNODE,DGQNODES,DGPC,DGPTND,DGRPS,DGQ,DGX,DQ,N,X,Y,%Y
+10 SET (DGERR,DGRPS,DGCHANGE)=0
+11 if '($GET(DFN)&($GET(DGQCODE)="ADD1"))
GOTO QTE
+12 SET DGPC=2
SET DGCODE="ADD1"
+13 SET DGDR=104
+14 SET DGRPS=1
+15 SET DGQNODES=".11~.13"
+16 FOR N=1:1
SET DGNODE=$PIECE(DGQNODES,"~",N)
if DGNODE']""
QUIT
SET DGPTND(DGNODE)=$GET(^DPT(DFN,DGNODE))
+17 DO ^DGRPE
+18 FOR DGNODE=0:0
SET DGNODE=$ORDER(DGPTND(DGNODE))
if DGNODE']""
QUIT
if $GET(^DPT(DFN,DGNODE))'=(DGPTND(DGNODE))
SET DGCHANGE=1
QTE IF 'DGRPS
SET DGERR=1
QTQ QUIT
+1 ;FORM FEED & STOPPING UTILITIES
FIRST() ;First heading of report
+1 ; RETURNS STOP; 0=GO,1=STOP
+2 NEW STOP
+3 DO STOPCHK
+4 if $GET(STOP)
DO STOPPED
+5 IF '$GET(STOP)
IF $EXTRACT($GET(IOST),1,2)="C-"
WRITE @IOF
+6 QUIT $GET(STOP)
+7 ;
SUBSEQ() ;enter for further headings of report
+1 ; RETURNS STOP; 0=GO,1=STOP
+2 NEW STOP,DIR,X,Y
+3 DO STOPCHK
+4 IF $EXTRACT($GET(IOST),1,2)="C-"
SET DIR(0)="E"
DO ^DIR
if $DATA(DIRUT)
SET STOP=1
+5 if $GET(STOP)
DO STOPPED
+6 IF '$GET(STOP)
WRITE @IOF
+7 QUIT $GET(STOP)
+8 ;
STOPCHK IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (ZTSTOP,STOP)=1
+1 QUIT
STOPPED ;
+1 WRITE !?5,"------------- Report stopped at user's request ------------"
+2 KILL ZTREQ
+3 QUIT
ENDREP IF $EXTRACT(IOST,1,2)'["C-"
if $Y&'$DATA(IONOFF)
WRITE @IOF
QUIT
+1 QUIT
+2 ;
ASKDIV(NOTALL) ;Ask for division (one/many/all)
+1 ; Input: NOTALL - Flag that prevents selection of all divisions
+2 ; 1 = Don't allow selection of all divisions
+3 ; 0 = Allow selection of all divisions (default)
+4 ;Output: Integer indicating if selection was made
+5 ; 0 = No divisions selected (user quit)
+6 ; 1 = Divisions selected
+7 ; VAUTD will be set as follows:
+8 ; VAUTD = 1 if all divisions selected
+9 ; VAUTD = 0 if individual divisions selected
+10 ; VAUTD(DivPtr) = DivisionName for each division selected
+11 ; Notes: VAUTD is KILLed in input
+12 ;
+13 NEW FIRSTDIV,MULTIDIV,Y,VAUTNALL
+14 KILL VAUTD
+15 SET FIRSTDIV=+$ORDER(^DG(40.80,0))
+16 IF '$DATA(^DG(40.8,FIRSTDIV,0))
Begin DoDot:1
+17 WRITE !
+18 WRITE $CHAR(7),"***WARNING...MEDICAL CENTER DIVISION FILE IS NOT SET UP***"
+19 WRITE !
End DoDot:1
GOTO ASKDIVQ
+20 SET MULTIDIV=+$PIECE($GET(^DG(43,1,"GL")),"^",2)
+21 IF 'MULTIDIV
SET VAUTD=1
GOTO ASKDIVQ
+22 SET (VAUTD,Y)=0
+23 IF +$GET(NOTALL)
SET VAUTNALL=1
+24 DO DIVISION^VAUTOMA
+25 IF Y<0
KILL VAUTD
ASKDIVQ QUIT $DATA(VAUTD)>0
+1 ;
EMGRES(DFN) ;DG*5.3*677
+1 ;This API returns the value of the Emergency Response
+2 ;Indicator (file 2, field .181), or null if blank
+3 ;
+4 ;INPUT:
+5 ; DFN - pointer to the Patient File (#2)
+6 ;
+7 ;OUTPUT:
+8 ; Function value - returns value from E.R.I. field, or null if blank
+9 ;
+10 IF 'DFN
QUIT ""
+11 ;
+12 NEW RESULT
+13 SET RESULT=$PIECE($GET(^DPT(DFN,.18)),U)
+14 QUIT RESULT
