- DGRUGBGJ ;ALB/BOK/MLI - RUG-II BACK GROUND TRIGGER ; 07 MAR 87
- ;;5.3;Registration;**7,54,89**;Aug 13, 1993
- S U="^",X="N",%DT="R" D ^%DT S DGDT=+Y K X,Y S DGST=$S($D(^DG(43,1,"RUG")):$P(^("RUG"),U),1:0),DGSD=$S(+DGST:DGST-1,1:(DGDT-2)),IOP=$S($D(ION):ION,1:""),DGED=DGDT D ^%ZIS
- EN S DGFLG=0
- F R=DGSD:0 S R=$O(^DGPM("AMV2",R)) Q:R'>0!(R'<DGED) F DFN=0:0 S DFN=$O(^DGPM("AMV2",R,DFN)) Q:DFN'>0 S DGADM=$O(^(DFN,0)) I $D(^DGPM(+DGADM,0)) S X=^(0) D CK
- ADM F R=DGSD:0 S R=$O(^DGPM("AMV1",R)) Q:R'>0!(R'<DGED) F DFN=0:0 S DFN=$O(^DGPM("AMV1",R,DFN)) Q:DFN'>0 S DGADM=$O(^(DFN,0)) I $D(^DGPM(+DGADM,0)) S W0=$P(^(0),U,6),S=$S($D(^DIC(42,+W0,0)):$P(^(0),U,3),1:"") I S]"","NHI"[S S DGD=R\1 D FILE
- PRT S W=0 F W1=0:0 S W=$O(^UTILITY($J,"PAI",W)) Q:W="" D HEAD F I=0:0 S I=$O(^UTILITY($J,"PAI",W,I)) Q:I'>0 F D=0:0 S D=$O(^UTILITY($J,"PAI",W,I,D)) Q:D'>0 S DGI=^(D) W !,$E($P(DGI,U),1,25),?27,$P(DGI,U,2),?55 S Y=D D DT^DIQ
- W !
- QUIT S X="N",%DT="R" D ^%DT S $P(^DG(43,1,"RUG"),U)=+Y W @IOF
- K %DT,D,DA,DFN,DGADM,DGD,DGDT,DGED,DGFLG,DGI,DGMT,DGSD,DGSSN,DGST,DIC,DIE,DLAYGO,DR,I,N,N1,R,S,S1,W,W0,W1,X,Y,^UTILITY($J),VAERR,VAIP Q
- HEAD W @IOF,!,$P(^DIC(42,+W,0),U),?60,"DATE: " S Y=$P(DGDT,".") D DT^DIQ
- W !!,"PATIENT ASSESSMENT INSTRUMENTS HAVE BEEN CREATED FOR THE FOLLOWING PATIENTS ",!?25,"DUE TO ADMISSION/TRANSFER IN",!!,?5,"NAME",?31,"SSN",?46,"DATE OF ADMISSION/TRANSFER IN"
- Q
- CK S DGMT=$S($P(X,"^",18):$P(X,"^",18),1:"")
- I $S(DGMT=4:1,DGMT=14:1,DGMT=44:1,1:0) S W0=+$P(X,U,6),S=$S($D(^DIC(42,+W0,0)):$P(^(0),U,3),1:" "),DGFLG=0 I "NHI"[S D PREV I 'DGFLG S DGD=R\1 D FILE
- Q
- PREV S VAIP("D")=R D IN5^VADPT
- S N=+VAIP(15,1) I N>0 S W1=+VAIP(15,4),S1=$P(^DIC(42,W1,0),U,3) S:((S="NH"&(S1="NH"))!(S="I"&(S1="I"))) DGFLG=1
- I N<0,$D(^DGPM(DGADM,0)) S W1=$P(^(0),"^",6),S1=$P(^DIC(42,W1,0),"^",3) I (S="NH"&(S1="NH"))!(S="I"&(S1="I")) S DGFLG=1
- Q
- FILE Q:$D(^DG(45.9,"AT",1,DGD,DFN))
- S DLAYGO=45.9,DGSSN=$E($P(^DPT(DFN,0),U,9),1,9),X=DFN,DIC="^DG(45.9,",DIC(0)="L" D FILE^DICN G:Y'>0 BUL
- S DA=+Y,DIE="^DG(45.9,",W0=W0_";DIC(42,"
- S DR="6///1;2///"_DGD_";3///"_DGSSN_";7///"_DGD_";70////^S X=W0;9///"_S_";80///5"
- D ^DIE
- S ^UTILITY($J,"PAI",W0,DFN,DGD)=$P(^DPT(DFN,0),U)_U_DGSSN Q
- BUL W !,"There was an attempt to set up a PAI record on ",$P(^DPT(DFN,0),U)," ",$P(^(0),U,9),!,"Please verify that this patient's data is accurate and create a PAI record." Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRUGBGJ 2390 printed Feb 19, 2025@00:24:19 Page 2
- DGRUGBGJ ;ALB/BOK/MLI - RUG-II BACK GROUND TRIGGER ; 07 MAR 87
- +1 ;;5.3;Registration;**7,54,89**;Aug 13, 1993
- +2 SET U="^"
- SET X="N"
- SET %DT="R"
- DO ^%DT
- SET DGDT=+Y
- KILL X,Y
- SET DGST=$SELECT($DATA(^DG(43,1,"RUG")):$PIECE(^("RUG"),U),1:0)
- SET DGSD=$SELECT(+DGST:DGST-1,1:(DGDT-2))
- SET IOP=$SELECT($DATA(ION):ION,1:"")
- SET DGED=DGDT
- DO ^%ZIS
- EN SET DGFLG=0
- +1 FOR R=DGSD:0
- SET R=$ORDER(^DGPM("AMV2",R))
- if R'>0!(R'<DGED)
- QUIT
- FOR DFN=0:0
- SET DFN=$ORDER(^DGPM("AMV2",R,DFN))
- if DFN'>0
- QUIT
- SET DGADM=$ORDER(^(DFN,0))
- IF $DATA(^DGPM(+DGADM,0))
- SET X=^(0)
- DO CK
- ADM FOR R=DGSD:0
- SET R=$ORDER(^DGPM("AMV1",R))
- if R'>0!(R'<DGED)
- QUIT
- FOR DFN=0:0
- SET DFN=$ORDER(^DGPM("AMV1",R,DFN))
- if DFN'>0
- QUIT
- SET DGADM=$ORDER(^(DFN,0))
- IF $DATA(^DGPM(+DGADM,0))
- SET W0=$PIECE(^(0),U,6)
- SET S=$SELECT($DATA(^DIC(42,+W0,0)):$PIECE(^(0),U,3),1:"")
- IF S]""
- IF "NHI"[S
- SET DGD=R\1
- DO FILE
- PRT SET W=0
- FOR W1=0:0
- SET W=$ORDER(^UTILITY($JOB,"PAI",W))
- if W=""
- QUIT
- DO HEAD
- FOR I=0:0
- SET I=$ORDER(^UTILITY($JOB,"PAI",W,I))
- if I'>0
- QUIT
- FOR D=0:0
- SET D=$ORDER(^UTILITY($JOB,"PAI",W,I,D))
- if D'>0
- QUIT
- SET DGI=^(D)
- WRITE !,$EXTRACT($PIECE(DGI,U),1,25),?27,$PIECE(DGI,U,2),?55
- SET Y=D
- DO DT^DIQ
- +1 WRITE !
- QUIT SET X="N"
- SET %DT="R"
- DO ^%DT
- SET $PIECE(^DG(43,1,"RUG"),U)=+Y
- WRITE @IOF
- +1 KILL %DT,D,DA,DFN,DGADM,DGD,DGDT,DGED,DGFLG,DGI,DGMT,DGSD,DGSSN,DGST,DIC,DIE,DLAYGO,DR,I,N,N1,R,S,S1,W,W0,W1,X,Y,^UTILITY($JOB),VAERR,VAIP
- QUIT
- HEAD WRITE @IOF,!,$PIECE(^DIC(42,+W,0),U),?60,"DATE: "
- SET Y=$PIECE(DGDT,".")
- DO DT^DIQ
- +1 WRITE !!,"PATIENT ASSESSMENT INSTRUMENTS HAVE BEEN CREATED FOR THE FOLLOWING PATIENTS ",!?25,"DUE TO ADMISSION/TRANSFER IN",!!,?5,"NAME",?31,"SSN",?46,"DATE OF ADMISSION/TRANSFER IN"
- +2 QUIT
- CK SET DGMT=$SELECT($PIECE(X,"^",18):$PIECE(X,"^",18),1:"")
- +1 IF $SELECT(DGMT=4:1,DGMT=14:1,DGMT=44:1,1:0)
- SET W0=+$PIECE(X,U,6)
- SET S=$SELECT($DATA(^DIC(42,+W0,0)):$PIECE(^(0),U,3),1:" ")
- SET DGFLG=0
- IF "NHI"[S
- DO PREV
- IF 'DGFLG
- SET DGD=R\1
- DO FILE
- +2 QUIT
- PREV SET VAIP("D")=R
- DO IN5^VADPT
- +1 SET N=+VAIP(15,1)
- IF N>0
- SET W1=+VAIP(15,4)
- SET S1=$PIECE(^DIC(42,W1,0),U,3)
- if ((S="NH"&(S1="NH"))!(S="I"&(S1="I")))
- SET DGFLG=1
- +2 IF N<0
- IF $DATA(^DGPM(DGADM,0))
- SET W1=$PIECE(^(0),"^",6)
- SET S1=$PIECE(^DIC(42,W1,0),"^",3)
- IF (S="NH"&(S1="NH"))!(S="I"&(S1="I"))
- SET DGFLG=1
- +3 QUIT
- FILE if $DATA(^DG(45.9,"AT",1,DGD,DFN))
- QUIT
- +1 SET DLAYGO=45.9
- SET DGSSN=$EXTRACT($PIECE(^DPT(DFN,0),U,9),1,9)
- SET X=DFN
- SET DIC="^DG(45.9,"
- SET DIC(0)="L"
- DO FILE^DICN
- if Y'>0
- GOTO BUL
- +2 SET DA=+Y
- SET DIE="^DG(45.9,"
- SET W0=W0_";DIC(42,"
- +3 SET DR="6///1;2///"_DGD_";3///"_DGSSN_";7///"_DGD_";70////^S X=W0;9///"_S_";80///5"
- +4 DO ^DIE
- +5 SET ^UTILITY($JOB,"PAI",W0,DFN,DGD)=$PIECE(^DPT(DFN,0),U)_U_DGSSN
- QUIT
- BUL WRITE !,"There was an attempt to set up a PAI record on ",$PIECE(^DPT(DFN,0),U)," ",$PIECE(^(0),U,9),!,"Please verify that this patient's data is accurate and create a PAI record."
- QUIT