GMTSDCB ; SLC/TRS,KER - Brief Discharge ; 03/24/2004
;;2.7;Health Summary;**28,49,71**;Oct 20, 1995
;
; External References
; DBIA 3390 $$ICDDX^ICDCODE
; DBIA 10035 ^DPT(
; DBIA 1372 ^DGPT(
; DBIA 10082 ^ICD9(
; DBIA 10015 EN^DIQ1 (file #45)
; DBIA 3145 ^DIC(42.4,
; DBIA 3146 ^DIC(45.6,
;
ENDC ; Brief Discharge (no captions)
S N="",ADM=GMTS1,GMC=0,LF=0
I $D(GMTSNDM),(GMTSNDM>0) S CNTR=GMTSNDM
E S CNTR=100
S T1=GMTSEND,T2=GMTSBEG
F S ADM=$O(^DPT(DFN,"DA","AA",ADM)) Q:'ADM!(ADM>GMTS2) F S N=$O(^DPT(DFN,"DA","AA",ADM,N)) Q:'N D PROC I CNTR=0 Q
D KILLADM Q
PROC ; Process Admissions
S AD0=^DPT(DFN,"DA",N,0),PTF=$P(AD0,U,12)
S CNTR=CNTR-1 I CNTR=0 Q
I $S('PTF:1,1:'$D(^DGPT(PTF,70))) S GMC=-1 Q
S:$D(^DGPT(PTF,70)) ICD=^DGPT(PTF,70)
I $P(ICD,"^",1)="" S GMC=-1 Q
S DATE=$P((ICD),"^",1) I (DATE'<T1)!(DATE'>T2) Q:GMC S GMC=-1 Q
S GMC=2 S X=DATE D REGDT4^GMTSU S XD=X
I $P(ICD,U,10)'="" N ICDX S ICDX=$$ICDDX^ICDCODE($P(ICD,U,10)),DXL=$P(ICDX,"^",4)
I $P((ICD),"^",2)'="" S BS=$P((ICD),"^",2),BS=$S($D(^DIC(42.4,BS,0)):^DIC(42.4,BS,0),1:"") S BDS=$S($P((BS),"^",2)'="":$P(BS,U,2),$P(BS,U,1)'="":$P(BS,U,1),1:"UNKNOWN")
I $P(ICD,"^",3)'="" S DIC="^DGPT(",DR=72,DA=PTF,DIQ="ARRAY",DIQ(0)="E" D EN^DIQ1 S SDS=ARRAY(45,DA,72,"E")
S DP=$S($P((ICD),"^",6)'="":$P(ICD,U,6),1:""),DP=$S(DP'="":^DIC(45.6,DP,0),1:"")
S OT=$P(ICD,"^",4),OP=$S(OT=3:"NO",OT="":"UNKNOWN",1:"YES")
D CKP^GMTSUP Q:$D(GMTSQIT) W ?3,XD,?21,SDS,!
I $D(DXL) D CKP^GMTSUP Q:$D(GMTSQIT) W ?15,"DXLS: ",DXL,!
K DXL,BS,BDS,ICD,DATE
Q
KILLADM ; Kills Admission variables
K END,TDT,HH,MM,TN,LF,DATE,AT,ITR,TRT,TI,TO,N,CNTR,BDS,SDS,GMC,ARRAY,DXL,TOM,TR,T1,T2,DATE,I,A,AD0,ADM,BS,D,DA,DP,DR,ICD,OP,OT,PTF,X,XD,DIQ,DIC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSDCB 1818 printed Dec 13, 2024@01:57:12 Page 2
GMTSDCB ; SLC/TRS,KER - Brief Discharge ; 03/24/2004
+1 ;;2.7;Health Summary;**28,49,71**;Oct 20, 1995
+2 ;
+3 ; External References
+4 ; DBIA 3390 $$ICDDX^ICDCODE
+5 ; DBIA 10035 ^DPT(
+6 ; DBIA 1372 ^DGPT(
+7 ; DBIA 10082 ^ICD9(
+8 ; DBIA 10015 EN^DIQ1 (file #45)
+9 ; DBIA 3145 ^DIC(42.4,
+10 ; DBIA 3146 ^DIC(45.6,
+11 ;
ENDC ; Brief Discharge (no captions)
+1 SET N=""
SET ADM=GMTS1
SET GMC=0
SET LF=0
+2 IF $DATA(GMTSNDM)
IF (GMTSNDM>0)
SET CNTR=GMTSNDM
+3 IF '$TEST
SET CNTR=100
+4 SET T1=GMTSEND
SET T2=GMTSBEG
+5 FOR
SET ADM=$ORDER(^DPT(DFN,"DA","AA",ADM))
if 'ADM!(ADM>GMTS2)
QUIT
FOR
SET N=$ORDER(^DPT(DFN,"DA","AA",ADM,N))
if 'N
QUIT
DO PROC
IF CNTR=0
QUIT
+6 DO KILLADM
QUIT
PROC ; Process Admissions
+1 SET AD0=^DPT(DFN,"DA",N,0)
SET PTF=$PIECE(AD0,U,12)
+2 SET CNTR=CNTR-1
IF CNTR=0
QUIT
+3 IF $SELECT('PTF:1,1:'$DATA(^DGPT(PTF,70)))
SET GMC=-1
QUIT
+4 if $DATA(^DGPT(PTF,70))
SET ICD=^DGPT(PTF,70)
+5 IF $PIECE(ICD,"^",1)=""
SET GMC=-1
QUIT
+6 SET DATE=$PIECE((ICD),"^",1)
IF (DATE'<T1)!(DATE'>T2)
if GMC
QUIT
SET GMC=-1
QUIT
+7 SET GMC=2
SET X=DATE
DO REGDT4^GMTSU
SET XD=X
+8 IF $PIECE(ICD,U,10)'=""
NEW ICDX
SET ICDX=$$ICDDX^ICDCODE($PIECE(ICD,U,10))
SET DXL=$PIECE(ICDX,"^",4)
+9 IF $PIECE((ICD),"^",2)'=""
SET BS=$PIECE((ICD),"^",2)
SET BS=$SELECT($DATA(^DIC(42.4,BS,0)):^DIC(42.4,BS,0),1:"")
SET BDS=$SELECT($PIECE((BS),"^",2)'="":$PIECE(BS,U,2),$PIECE(BS,U,1)'="":$PIECE(BS,U,1),1:"UNKNOWN")
+10 IF $PIECE(ICD,"^",3)'=""
SET DIC="^DGPT("
SET DR=72
SET DA=PTF
SET DIQ="ARRAY"
SET DIQ(0)="E"
DO EN^DIQ1
SET SDS=ARRAY(45,DA,72,"E")
+11 SET DP=$SELECT($PIECE((ICD),"^",6)'="":$PIECE(ICD,U,6),1:"")
SET DP=$SELECT(DP'="":^DIC(45.6,DP,0),1:"")
+12 SET OT=$PIECE(ICD,"^",4)
SET OP=$SELECT(OT=3:"NO",OT="":"UNKNOWN",1:"YES")
+13 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?3,XD,?21,SDS,!
+14 IF $DATA(DXL)
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?15,"DXLS: ",DXL,!
+15 KILL DXL,BS,BDS,ICD,DATE
+16 QUIT
KILLADM ; Kills Admission variables
+1 KILL END,TDT,HH,MM,TN,LF,DATE,AT,ITR,TRT,TI,TO,N,CNTR,BDS,SDS,GMC,ARRAY,DXL,TOM,TR,T1,T2,DATE,I,A,AD0,ADM,BS,D,DA,DP,DR,ICD,OP,OT,PTF,X,XD,DIQ,DIC
+2 QUIT
