- DGJBGJ ;ALB/MAF - IRT BACKGROUND JOB/SHORT FORM LIST - MAY 3 1993
- ;;5.3;Registration;**126,1015**;Aug 13, 1993;Build 21
- EN N DGJBG,DGJED
- D DAT
- I Y=-1 G QUIT
- ;D START Q ;Line for testing
- S ZTIO="",ZTRTN="START^DGJBGJ",ZTDESC="IRT Background Job to Initialize admissions with standard deficiencies"
- F X="DGJBG","DGJED" S ZTSAVE(X)=""
- K ZTSK D ^%ZTLOAD W:$D(ZTSK) " (TASK: #",ZTSK,")"
- Q
- AUTO ;Nightly Job Entry Point
- S X1=DT,X2=-2 D C^%DTC
- S (DGJFLAG,DGJFLG)=0
- S DGJBG=X,DGJED=X+.2359 D SHORT
- S X1=DT,X2=-1 D C^%DTC
- S DGJBG=X,DGJED=X+.2359 D START
- Q
- SHORT S DGJX=0,DGJDEF=0,DGJDA=0
- F S DGJBG=$O(^DGPM("B",DGJBG)) Q:DGJBG']""!(DGJBG>DGJED) F S DGJDA=$O(^DGPM("B",DGJBG,DGJDA)) Q:'DGJDA I $D(^DGPM(DGJDA,0)),$P(^DGPM(DGJDA,0),"^",2)=1,$P(^DGPM(DGJDA,0),"^",17) D SET,CK
- Q
- CK S DGJFLAG=0,X2=$P($G(^DGPM(+DGJCA,0)),"^",1),X1=$P($G(^DGPM(+DGJDIS,0)),"^",1) Q:X1=X2 D ^%DTC I X<2 D SETUP S DGJFLAG=1
- Q
- SETSTR(S,V,X,L) ; -- insert text(S) into variable(V)
- ; S := string
- ; V := destination
- ; X := @ col X
- ; L := # of chars
- ;
- Q $E(V_$J("",X-1),1,X-1)_$E(S_$J("",L),1,L)_$E(V,X+L,999)
- SETUP S DFN=$P(DGJTND,"^",3) D PID^VADPT6 S VAIP("D")=$P(^DGPM(DGJDIS,0),"^",1)-.000001 D IN5^VADPT S X=+VAIP(5) S DGJDIV=$S($D(^DIC(42,+X,0)):$P(^DIC(42,X,0),"^",11),1:"")
- I $D(^DGPM(+DGJDIS,0)) S DGJTTYP=$P(^(0),"^",4) S DGJTTYP=$S($D(^DG(405.1,+DGJTTYP,0)):$E($P(^(0),"^",1),1,20),1:"")
- S X=""
- S X=$$SETSTR($E($P(^DPT($P(DGJTND,"^",3),0),"^",1),1,15),X,1,15)
- S X=$$SETSTR(VA("BID"),X,19,5)
- S X=$$SETSTR($$FTIME^VALM1($P($G(^DGPM(DGJCA,0)),"^",1)),X,28,18)
- S X=$$SETSTR(DGJTTYP,X,50,15)
- S X=$$SETSTR($S($G(^DG(40.8,+DGJDIV,0))]"":$P(^DG(40.8,+DGJDIV,0),"^",1),1:""),X,69,11)
- S ^TMP("VAS",$J,$S($G(^DG(40.8,+DGJDIV,0))]"":$P(^DG(40.8,+DGJDIV,0),"^",1),1:""),$P($G(^DGPM(DGJCA,0)),"^"),DGJCA,0)=X
- Q
- SET S (DGJTND,DGJCA,DGJDIS)="" S DGJTND=$G(^DGPM(DGJDA,0)),DGJCA=$P(DGJTND,"^",14),DGJDIS=$P(DGJTND,"^",17) S:DGJDIS']"" DGJFLG=1 Q
- START S (DGJFLAG,DGJFLG)=0 D NOW^%DTC S DGJDATE=%
- S DGJX=0,DGJDEF=0,DGJDA=0
- F S DGJDEF=$O(^VAS(393.3,DGJDEF)) Q:DGJDEF']"" S DGJNODE=$G(^VAS(393.3,DGJDEF,0)) I $P(DGJNODE,"^",8)=1,DGJDEF'=$O(^VAS(393.3,"B","DISCHARGE SUMMARY",0)) S DGJAR(DGJDEF)=""
- F S DGJBG=$O(^DGPM("B",DGJBG)) Q:DGJBG']""!(DGJBG>DGJED) F S DGJDA=$O(^DGPM("B",DGJBG,DGJDA)) Q:'DGJDA I $D(^DGPM(DGJDA,0)),$P(^DGPM(DGJDA,0),"^",2)=1 D SET D:DGJDIS]"" CK D:DGJFLAG DIV I DGJFLG,'$D(^DGPM(+DGJCA,"IRT")) D UP,FL
- S DIE="^DG(43,",DA=1,DR="401///"_DGJDATE D ^DIE K DA,DR
- D MSG^DGJBGJ1
- QUIT K %,%DT,DFN,DGJAR,DGJBG,DGJCA,DGJDA,DGJDATE,DGJDEF,DGJED,DGJEVT,DGJFDE,DGJNODE,DGJT,DGJT10,DGJT9,DGJTBEG,DGJTBG,DGJTDEL,DGJTDIV,DGJED,DGJTND,DGJTPR,DGJTSP,DGJTST,DGJTSV,DGJTWD,DGJTWD1,DGJX,DGJY,DIC,DIE,DLAYGO,DR,VAIP,X,X1,X2,Y
- K DGJB,DGJDIS,DGJDIV,DGJI,DGJMSG,DGJSTD,DGJTTYP,VA,DGJBG,DGJDA,DGJDEF,DGJED,DGJFLAG,DGJFLG,DGJTCNT,DGJX,X,DGJTWARD,VAERR,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,^TMP("VAS",$J) Q
- UP S DGJFLG=0,DFN=$P(DGJTND,"^",3) Q:DFN']"" S VAIP("D")=$S(DGJDIS]""&($D(^DGPM(+DGJDIS,0))):$P(^DGPM(DGJDIS,0),"^",1)-.000001,1:"L")
- D IN5^VADPT
- S DGJTWARD=+VAIP(5)
- S DGJTWD=$S($D(^DIC(42,DGJTWARD,0)):^DIC(42,DGJTWARD,44),1:"")
- S DGJTSV=$S(DGJTWARD]"":$P(^DIC(42,+DGJTWARD,0),"^",3),1:"")
- S DGJTSP=+VAIP(8)
- S:DGJTSV="" DGJTSV=0 S DGJTSV=$S(DGJTSV=0:12,$D(^DG(393.1,"AC",DGJTSV)):$O(^(DGJTSV,0)),1:"")
- S DGJEVT=+DGJTND
- S DGJTDIV=$S($D(^DIC(42,DGJTWARD,0)):$P(^DIC(42,DGJTWARD,0),"^",11),1:"")
- S DGJTDEL=$G(^DG(40.8,+DGJTDIV,"DT"))
- S DGJT=$O(^DGPM("ATS",DFN,DGJCA,0)),DGJT=$O(^(+DGJT,0)),DGJT=$O(^(+DGJT,0)),DGJT=$S($D(^DGPM(+DGJT,0)):^(0),1:"") ;last TS mvt
- S DGJX=8,DGJY=2 D DOC S DGJT9=$S(X]"":X,1:"@"),X=""
- S DGJT10="" I $P(DGJTDEL,"^",3)!('$P(DGJTDEL,"^",3)&($P(DGJTDEL,"^",10)="A")) S DGJX=19,DGJY=4 D DOC S DGJT10=$S(X]"":X,1:"@")
- S DGJTPR=DGJT9
- Q
- FL S DGJFDE=0
- F S DGJFDE=$O(DGJAR(DGJFDE)) Q:DGJFDE']"" D FL1
- Q
- FL1 S X=DFN,DIC="^VAS(393,",DIC(0)="L",DLAYGO=393 K DD,DO D FILE^DICN
- S DGJTST=$O(^DG(393.2,"B","INCOMPLETE",0))
- I Y>0 S DIE=DIC,DA=+Y
- I Y>0 S DR=".02////"_DGJFDE_";.03////"_DGJEVT_";.04////"_DGJCA_";.05////"_DGJTWD_";.06////"_DGJTDIV_";.07////"_DGJTSP_";.08////"_DGJTSV_";.09////"_DGJT9_";.1////"_DGJT10_";.11////"_DGJTST_";.12////"_DGJT9
- I Y>0 D ^DIE K DA,DR S DIE="^DGPM(",DA=DGJCA,DR="60.01///"_DGJDATE D ^DIE K DA,DR
- Q
- DIV S (DGJFLG,DGJFLAG)=0 I $D(^DG(40.8,DGJDIV,"DT")) S DGJSTD=$P(^DG(40.8,DGJDIV,"DT"),"^",11) I DGJSTD=1 S DGJFLG=1
- Q
- DOC ;provider resp.
- S X=$P(DGJTDEL,"^",DGJY)
- S X=$S(X="A":$P(DGJT,"^",19),X="N":"",1:$P(DGJT,"^",8))
- Q
- DAT ;DATE RANGE
- BEG W ! S %DT="AEX",%DT("A")="Select Beginning Date: " D ^%DT S DGJBG=Y S:X="^"!(X="") Y=-1 Q:Y=-1 D NOW^%DTC I DGJBG>$P(%,".",1) W !!,"Dates in the future are not allowed!" G BEG
- END W ! S %DT("A")="Select Ending Date : " D ^%DT S:X="^"!(X="") Y=-1 Q:Y=-1 I Y<1 D HELP^%DTC G END
- S DGJED=Y_.2359
- I DGJED\1<DGJBG W !!?5,"The ending date cannot be before the beginning date" G END
- Q
- DGJBGJ ;ALB/MAF - IRT BACKGROUND JOB/SHORT FORM LIST - MAY 3 1993
- +1 ;;5.3;Registration;**126,1015**;Aug 13, 1993;Build 21
- EN NEW DGJBG,DGJED
- +1 DO DAT
- +2 IF Y=-1
- GOTO QUIT
- +3 ;D START Q ;Line for testing
- +4 SET ZTIO=""
- SET ZTRTN="START^DGJBGJ"
- SET ZTDESC="IRT Background Job to Initialize admissions with standard deficiencies"
- +5 FOR X="DGJBG","DGJED"
- SET ZTSAVE(X)=""
- +6 KILL ZTSK
- DO ^%ZTLOAD
- IF $DATA(ZTSK)
- WRITE " (TASK: #",ZTSK,")"
- +7 QUIT
- AUTO ;Nightly Job Entry Point
- +1 SET X1=DT
- SET X2=-2
- DO C^%DTC
- +2 SET (DGJFLAG,DGJFLG)=0
- +3 SET DGJBG=X
- SET DGJED=X+.2359
- DO SHORT
- +4 SET X1=DT
- SET X2=-1
- DO C^%DTC
- +5 SET DGJBG=X
- SET DGJED=X+.2359
- DO START
- +6 QUIT
- SHORT SET DGJX=0
- SET DGJDEF=0
- SET DGJDA=0
- +1 FOR
- SET DGJBG=$ORDER(^DGPM("B",DGJBG))
- IF DGJBG']""!(DGJBG>DGJED)
- QUIT
- FOR
- SET DGJDA=$ORDER(^DGPM("B",DGJBG,DGJDA))
- IF 'DGJDA
- QUIT
- IF $DATA(^DGPM(DGJDA,0))
- IF $PIECE(^DGPM(DGJDA,0),"^",2)=1
- IF $PIECE(^DGPM(DGJDA,0),"^",17)
- DO SET
- DO CK
- +2 QUIT
- CK SET DGJFLAG=0
- SET X2=$PIECE($GET(^DGPM(+DGJCA,0)),"^",1)
- SET X1=$PIECE($GET(^DGPM(+DGJDIS,0)),"^",1)
- IF X1=X2
- QUIT
- DO ^%DTC
- IF X<2
- DO SETUP
- SET DGJFLAG=1
- +1 QUIT
- SETSTR(S,V,X,L) ; -- insert text(S) into variable(V)
- +1 ; S := string
- +2 ; V := destination
- +3 ; X := @ col X
- +4 ; L := # of chars
- +5 ;
- +6 QUIT $EXTRACT(V_$JUSTIFY("",X-1),1,X-1)_$EXTRACT(S_$JUSTIFY("",L),1,L)_$EXTRACT(V,X+L,999)
- SETUP SET DFN=$PIECE(DGJTND,"^",3)
- DO PID^VADPT6
- SET VAIP("D")=$PIECE(^DGPM(DGJDIS,0),"^",1)-.000001
- DO IN5^VADPT
- SET X=+VAIP(5)
- SET DGJDIV=$SELECT($DATA(^DIC(42,+X,0)):$PIECE(^DIC(42,X,0),"^",11),1:"")
- +1 IF $DATA(^DGPM(+DGJDIS,0))
- SET DGJTTYP=$PIECE(^(0),"^",4)
- SET DGJTTYP=$SELECT($DATA(^DG(405.1,+DGJTTYP,0)):$EXTRACT($PIECE(^(0),"^",1),1,20),1:"")
- +2 SET X=""
- +3 SET X=$$SETSTR($EXTRACT($PIECE(^DPT($PIECE(DGJTND,"^",3),0),"^",1),1,15),X,1,15)
- +4 SET X=$$SETSTR(VA("BID"),X,19,5)
- +5 SET X=$$SETSTR($$FTIME^VALM1($PIECE($GET(^DGPM(DGJCA,0)),"^",1)),X,28,18)
- +6 SET X=$$SETSTR(DGJTTYP,X,50,15)
- +7 SET X=$$SETSTR($SELECT($GET(^DG(40.8,+DGJDIV,0))]"":$PIECE(^DG(40.8,+DGJDIV,0),"^",1),1:""),X,69,11)
- +8 SET ^TMP("VAS",$JOB,$SELECT($GET(^DG(40.8,+DGJDIV,0))]"":$PIECE(^DG(40.8,+DGJDIV,0),"^",1),1:""),$PIECE($GET(^DGPM(DGJCA,0)),"^"),DGJCA,0)=X
- +9 QUIT
- SET SET (DGJTND,DGJCA,DGJDIS)=""
- SET DGJTND=$GET(^DGPM(DGJDA,0))
- SET DGJCA=$PIECE(DGJTND,"^",14)
- SET DGJDIS=$PIECE(DGJTND,"^",17)
- IF DGJDIS']""
- SET DGJFLG=1
- QUIT
- START SET (DGJFLAG,DGJFLG)=0
- DO NOW^%DTC
- SET DGJDATE=%
- +1 SET DGJX=0
- SET DGJDEF=0
- SET DGJDA=0
- +2 FOR
- SET DGJDEF=$ORDER(^VAS(393.3,DGJDEF))
- IF DGJDEF']""
- QUIT
- SET DGJNODE=$GET(^VAS(393.3,DGJDEF,0))
- IF $PIECE(DGJNODE,"^",8)=1
- IF DGJDEF'=$ORDER(^VAS(393.3,"B","DISCHARGE SUMMARY",0))
- SET DGJAR(DGJDEF)=""
- +3 FOR
- SET DGJBG=$ORDER(^DGPM("B",DGJBG))
- IF DGJBG']""!(DGJBG>DGJED)
- QUIT
- FOR
- SET DGJDA=$ORDER(^DGPM("B",DGJBG,DGJDA))
- IF 'DGJDA
- QUIT
- IF $DATA(^DGPM(DGJDA,0))
- IF $PIECE(^DGPM(DGJDA,0),"^",2)=1
- DO SET
- IF DGJDIS]""
- DO CK
- IF DGJFLAG
- DO DIV
- IF DGJFLG
- IF '$DATA(^DGPM(+DGJCA,"IRT"))
- DO UP
- DO FL
- +4 SET DIE="^DG(43,"
- SET DA=1
- SET DR="401///"_DGJDATE
- DO ^DIE
- KILL DA,DR
- +5 DO MSG^DGJBGJ1
- QUIT KILL %,%DT,DFN,DGJAR,DGJBG,DGJCA,DGJDA,DGJDATE,DGJDEF,DGJED,DGJEVT,DGJFDE,DGJNODE,DGJT,DGJT10,DGJT9,DGJTBEG,DGJTBG,DGJTDEL,DGJTDIV,DGJED,DGJTND,DGJTPR,DGJTSP,DGJTST,DGJTSV,DGJTWD,DGJTWD1,DGJX,DGJY,DIC,DIE,DLAYGO,DR,VAIP,X,X1,X2,Y
- +1 KILL DGJB,DGJDIS,DGJDIV,DGJI,DGJMSG,DGJSTD,DGJTTYP,VA,DGJBG,DGJDA,DGJDEF,DGJED,DGJFLAG,DGJFLG,DGJTCNT,DGJX,X,DGJTWARD,VAERR,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,^TMP("VAS",$JOB)
- QUIT
- UP SET DGJFLG=0
- SET DFN=$PIECE(DGJTND,"^",3)
- IF DFN']""
- QUIT
- SET VAIP("D")=$SELECT(DGJDIS]""&($DATA(^DGPM(+DGJDIS,0))):$PIECE(^DGPM(DGJDIS,0),"^",1)-.000001,1:"L")
- +1 DO IN5^VADPT
- +2 SET DGJTWARD=+VAIP(5)
- +3 SET DGJTWD=$SELECT($DATA(^DIC(42,DGJTWARD,0)):^DIC(42,DGJTWARD,44),1:"")
- +4 SET DGJTSV=$SELECT(DGJTWARD]"":$PIECE(^DIC(42,+DGJTWARD,0),"^",3),1:"")
- +5 SET DGJTSP=+VAIP(8)
- +6 IF DGJTSV=""
- SET DGJTSV=0
- SET DGJTSV=$SELECT(DGJTSV=0:12,$DATA(^DG(393.1,"AC",DGJTSV)):$ORDER(^(DGJTSV,0)),1:"")
- +7 SET DGJEVT=+DGJTND
- +8 SET DGJTDIV=$SELECT($DATA(^DIC(42,DGJTWARD,0)):$PIECE(^DIC(42,DGJTWARD,0),"^",11),1:"")
- +9 SET DGJTDEL=$GET(^DG(40.8,+DGJTDIV,"DT"))
- +10 ;last TS mvt
- SET DGJT=$ORDER(^DGPM("ATS",DFN,DGJCA,0))
- SET DGJT=$ORDER(^(+DGJT,0))
- SET DGJT=$ORDER(^(+DGJT,0))
- SET DGJT=$SELECT($DATA(^DGPM(+DGJT,0)):^(0),1:"")
- +11 SET DGJX=8
- SET DGJY=2
- DO DOC
- SET DGJT9=$SELECT(X]"":X,1:"@")
- SET X=""
- +12 SET DGJT10=""
- IF $PIECE(DGJTDEL,"^",3)!('$PIECE(DGJTDEL,"^",3)&($PIECE(DGJTDEL,"^",10)="A"))
- SET DGJX=19
- SET DGJY=4
- DO DOC
- SET DGJT10=$SELECT(X]"":X,1:"@")
- +13 SET DGJTPR=DGJT9
- +14 QUIT
- FL SET DGJFDE=0
- +1 FOR
- SET DGJFDE=$ORDER(DGJAR(DGJFDE))
- IF DGJFDE']""
- QUIT
- DO FL1
- +2 QUIT
- FL1 SET X=DFN
- SET DIC="^VAS(393,"
- SET DIC(0)="L"
- SET DLAYGO=393
- KILL DD,DO
- DO FILE^DICN
- +1 SET DGJTST=$ORDER(^DG(393.2,"B","INCOMPLETE",0))
- +2 IF Y>0
- SET DIE=DIC
- SET DA=+Y
- +3 IF Y>0
- SET DR=".02////"_DGJFDE_";.03////"_DGJEVT_";.04////"_DGJCA_";.05////"_DGJTWD_";.06////"_DGJTDIV_";.07////"_DGJTSP_";.08////"_DGJTSV_";.09////"_DGJT9_";.1////"_DGJT10_";.11////"_DGJTST_";.12////"_DGJT9
- +4 IF Y>0
- DO ^DIE
- KILL DA,DR
- SET DIE="^DGPM("
- SET DA=DGJCA
- SET DR="60.01///"_DGJDATE
- DO ^DIE
- KILL DA,DR
- +5 QUIT
- DIV SET (DGJFLG,DGJFLAG)=0
- IF $DATA(^DG(40.8,DGJDIV,"DT"))
- SET DGJSTD=$PIECE(^DG(40.8,DGJDIV,"DT"),"^",11)
- IF DGJSTD=1
- SET DGJFLG=1
- +1 QUIT
- DOC ;provider resp.
- +1 SET X=$PIECE(DGJTDEL,"^",DGJY)
- +2 SET X=$SELECT(X="A":$PIECE(DGJT,"^",19),X="N":"",1:$PIECE(DGJT,"^",8))
- +3 QUIT
- DAT ;DATE RANGE
- BEG WRITE !
- SET %DT="AEX"
- SET %DT("A")="Select Beginning Date: "
- DO ^%DT
- SET DGJBG=Y
- IF X="^"!(X="")
- SET Y=-1
- IF Y=-1
- QUIT
- DO NOW^%DTC
- IF DGJBG>$PIECE(%,".",1)
- WRITE !!,"Dates in the future are not allowed!"
- GOTO BEG
- END WRITE !
- SET %DT("A")="Select Ending Date : "
- DO ^%DT
- IF X="^"!(X="")
- SET Y=-1
- IF Y=-1
- QUIT
- IF Y<1
- DO HELP^%DTC
- GOTO END
- +1 SET DGJED=Y_.2359
- +2 IF DGJED\1<DGJBG
- WRITE !!?5,"The ending date cannot be before the beginning date"
- GOTO END
- +3 QUIT