GMTSDCB.m

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

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