- GMTSDGA2 ; SLC/MKB,KER - Treating Spec for HS ; 02/27/2002
- ;;2.7;Health Summary;**28,49**;Oct 20, 1995
- ;
- ; External References
- ; DBIA 17 ^DGPM(
- ; DBIA 1003 ^DGS(41.1
- ; DBIA 3145 ^DIC(42.4
- ; DBIA 3147 ^DIC(45.7
- ; DBIA 10015 EN^DIQ1 (file 41.1)
- ; DBIA 10011 ^DIWP
- ;
- TSOUT ; Treating Speciality Output
- S X=+VAIP(13,1) D REGDT4^GMTSU S DDT=X
- S X=ADATE D MTIM^GMTSU S ADT=ADT_" "_X
- S TS=$P($G(^DIC(45.7,+VAIP(8),0)),U,2) S SPEC=$S($D(^DIC(42.4,+TS,0)):$P(^(0),U),1:"UNKNOWN")
- D CKP^GMTSUP Q:$D(GMTSQIT) W ADT,?21,$E(SPEC,1,25),?48,"(",DDT,")",?63,$E($P(VAIP(7),U,2),1,15),!
- K ^UTILITY($J,"W") I $D(^DGPM(ADA,"DX")) F GMJ=1:1:$P(^DGPM(ADA,"DX",0),"^",4) S X=^DGPM(ADA,"DX",GMJ,0),DIWL=27,DIWR=71,DIWF="C46R" D ^DIWP
- I $D(^UTILITY($J,"W")) D CKP^GMTSUP Q:$D(GMTSQIT) W ?21,"Diag: " S GMJ=$O(^UTILITY($J,"W",0)) Q:'GMJ S GMJ1=0 F GMZ=0:0 S GMJ1=$O(^UTILITY($J,"W",GMJ,GMJ1)) Q:'GMJ1 D CKP^GMTSUP Q:$D(GMTSQIT) W ?27,^UTILITY($J,"W",GMJ,GMJ1,0),!
- K DIWL,DIWF,DIWR,^UTILITY($J,"W")
- Q
- FADM ; Future Scheduled admission output
- N GMDT,NODE,X
- K ^TMP("GMFADM",$J)
- D GETFADM
- Q:'$D(^TMP("GMFADM",$J))
- S GMC=1
- S GMDT=0
- F S GMDT=$O(^TMP("GMFADM",$J,GMDT)) Q:GMDT'>0 D
- . I FLAG>1,'GMTSNPG D CKP^GMTSUP Q:$D(GMTSQIT) W !
- . D CKP^GMTSUP Q:$D(GMTSQIT)
- . S FLAG=2
- . S NODE=$G(^TMP("GMFADM",$J,GMDT))
- . S X=$P(NODE,U) D REGDT4^GMTSU
- . D CKP^GMTSUP Q:$D(GMTSQIT) W X," (Future)",?23,$E($P(NODE,U,5),1,24)
- . I $P(NODE,U,6)>0 W ?49,"Expected LOS: ",$P(NODE,U,6),!
- . D CKP^GMTSUP Q:$D(GMTSQIT) D
- . . I $P(NODE,U,2)]"" W "Admitting Diagnosis: ",$P(NODE,U,2)
- . . W ?51,"Provider: ",$E($P(NODE,U,3),1,15),!
- K ^TMP("GMFADM",$J)
- Q
- GETFADM ; Get future scheduled admission data
- N DA,DIQ,DIC,DR
- Q:'$D(^DGS(41.1,"B",DFN))
- K ^TMP("GMFADM",$J)
- S DA=0,DIC=41.1,DR="2;3;4;5;6;8;9;10;13;17"
- F S DA=$O(^DGS(41.1,"B",DFN,DA)) Q:DA'>0 D
- . N GMFADM,DIQ,RESDT,ADDX,PROV,SUR,LOC,LOS
- . S DIQ="GMFADM",DIQ(0)="IE"
- . D EN^DIQ1
- . ; Quit if reservation day is past,
- . ; admission cancel or patient admitted
- . Q:GMFADM(41.1,DA,13,"I")]""!(GMFADM(41.1,DA,17,"I")]"")!(GMFADM(41.1,DA,2,"I")<DT)
- . S RESDT=GMFADM(41.1,DA,2,"I"),ADDX=GMFADM(41.1,DA,4,"I")
- . S PROV=GMFADM(41.1,DA,5,"E"),SUR=GMFADM(41.1,DA,6,"E")
- . ; LOC will contain either ward or treating specialty
- . S LOC=$S(GMFADM(41.1,DA,10,"I")="W":GMFADM(41.1,DA,8,"E"),GMFADM(41.1,DA,10,"I")="T":GMFADM(41.1,DA,9,"E"),1:"")
- . S LOS=GMFADM(41.1,DA,3,"I")
- . S ^TMP("GMFADM",$J,9999999-RESDT)=RESDT_U_ADDX_U_PROV_U_SUR_U_LOC_U_LOS
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSDGA2 2628 printed Feb 18, 2025@23:23:43 Page 2
- GMTSDGA2 ; SLC/MKB,KER - Treating Spec for HS ; 02/27/2002
- +1 ;;2.7;Health Summary;**28,49**;Oct 20, 1995
- +2 ;
- +3 ; External References
- +4 ; DBIA 17 ^DGPM(
- +5 ; DBIA 1003 ^DGS(41.1
- +6 ; DBIA 3145 ^DIC(42.4
- +7 ; DBIA 3147 ^DIC(45.7
- +8 ; DBIA 10015 EN^DIQ1 (file 41.1)
- +9 ; DBIA 10011 ^DIWP
- +10 ;
- TSOUT ; Treating Speciality Output
- +1 SET X=+VAIP(13,1)
- DO REGDT4^GMTSU
- SET DDT=X
- +2 SET X=ADATE
- DO MTIM^GMTSU
- SET ADT=ADT_" "_X
- +3 SET TS=$PIECE($GET(^DIC(45.7,+VAIP(8),0)),U,2)
- SET SPEC=$SELECT($DATA(^DIC(42.4,+TS,0)):$PIECE(^(0),U),1:"UNKNOWN")
- +4 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ADT,?21,$EXTRACT(SPEC,1,25),?48,"(",DDT,")",?63,$EXTRACT($PIECE(VAIP(7),U,2),1,15),!
- +5 KILL ^UTILITY($JOB,"W")
- IF $DATA(^DGPM(ADA,"DX"))
- FOR GMJ=1:1:$PIECE(^DGPM(ADA,"DX",0),"^",4)
- SET X=^DGPM(ADA,"DX",GMJ,0)
- SET DIWL=27
- SET DIWR=71
- SET DIWF="C46R"
- DO ^DIWP
- +6 IF $DATA(^UTILITY($JOB,"W"))
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ?21,"Diag: "
- SET GMJ=$ORDER(^UTILITY($JOB,"W",0))
- if 'GMJ
- QUIT
- SET GMJ1=0
- FOR GMZ=0:0
- SET GMJ1=$ORDER(^UTILITY($JOB,"W",GMJ,GMJ1))
- if 'GMJ1
- QUIT
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ?27,^UTILITY($JOB,"W",GMJ,GMJ1,0),!
- +7 KILL DIWL,DIWF,DIWR,^UTILITY($JOB,"W")
- +8 QUIT
- FADM ; Future Scheduled admission output
- +1 NEW GMDT,NODE,X
- +2 KILL ^TMP("GMFADM",$JOB)
- +3 DO GETFADM
- +4 if '$DATA(^TMP("GMFADM",$JOB))
- QUIT
- +5 SET GMC=1
- +6 SET GMDT=0
- +7 FOR
- SET GMDT=$ORDER(^TMP("GMFADM",$JOB,GMDT))
- if GMDT'>0
- QUIT
- Begin DoDot:1
- +8 IF FLAG>1
- IF 'GMTSNPG
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE !
- +9 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- +10 SET FLAG=2
- +11 SET NODE=$GET(^TMP("GMFADM",$JOB,GMDT))
- +12 SET X=$PIECE(NODE,U)
- DO REGDT4^GMTSU
- +13 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE X," (Future)",?23,$EXTRACT($PIECE(NODE,U,5),1,24)
- +14 IF $PIECE(NODE,U,6)>0
- WRITE ?49,"Expected LOS: ",$PIECE(NODE,U,6),!
- +15 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- Begin DoDot:2
- +16 IF $PIECE(NODE,U,2)]""
- WRITE "Admitting Diagnosis: ",$PIECE(NODE,U,2)
- +17 WRITE ?51,"Provider: ",$EXTRACT($PIECE(NODE,U,3),1,15),!
- End DoDot:2
- End DoDot:1
- +18 KILL ^TMP("GMFADM",$JOB)
- +19 QUIT
- GETFADM ; Get future scheduled admission data
- +1 NEW DA,DIQ,DIC,DR
- +2 if '$DATA(^DGS(41.1,"B",DFN))
- QUIT
- +3 KILL ^TMP("GMFADM",$JOB)
- +4 SET DA=0
- SET DIC=41.1
- SET DR="2;3;4;5;6;8;9;10;13;17"
- +5 FOR
- SET DA=$ORDER(^DGS(41.1,"B",DFN,DA))
- if DA'>0
- QUIT
- Begin DoDot:1
- +6 NEW GMFADM,DIQ,RESDT,ADDX,PROV,SUR,LOC,LOS
- +7 SET DIQ="GMFADM"
- SET DIQ(0)="IE"
- +8 DO EN^DIQ1
- +9 ; Quit if reservation day is past,
- +10 ; admission cancel or patient admitted
- +11 if GMFADM(41.1,DA,13,"I")]""!(GMFADM(41.1,DA,17,"I")]"")!(GMFADM(41.1,DA,2,"I")<DT)
- QUIT
- +12 SET RESDT=GMFADM(41.1,DA,2,"I")
- SET ADDX=GMFADM(41.1,DA,4,"I")
- +13 SET PROV=GMFADM(41.1,DA,5,"E")
- SET SUR=GMFADM(41.1,DA,6,"E")
- +14 ; LOC will contain either ward or treating specialty
- +15 SET LOC=$SELECT(GMFADM(41.1,DA,10,"I")="W":GMFADM(41.1,DA,8,"E"),GMFADM(41.1,DA,10,"I")="T":GMFADM(41.1,DA,9,"E"),1:"")
- +16 SET LOS=GMFADM(41.1,DA,3,"I")
- +17 SET ^TMP("GMFADM",$JOB,9999999-RESDT)=RESDT_U_ADDX_U_PROV_U_SUR_U_LOC_U_LOS
- End DoDot:1
- +18 QUIT