DGRUGSA ;ALB/MLI/BOK - RUG-II BACK GROUND TRIGGER FOR SEMI-ANNUAL CENSUS ; 21 JAN 88
;;5.3;Registration;**7,54,89,104**;Aug 13, 1993
S DGPGM="1^DGRUGSA",DGVAR="" D ZIS^DGUTQ G:POP QUIT U IO D 1 Q
1 S DGSEMI="",X="T",%DT="",U="^" D ^%DT S DGH=+Y
S DGFL=0,DGY=$E(DGH,1,3),DGMD=$E(DGH,4,7) F I=0:1 S DGAD=$P($T(DATES+I),";;",2) Q:DGAD="QUIT" S X1=DGY_DGAD,X2=-31 D C^%DTC S DGB=X S X1=DGY_DGAD,X2=31 D C^%DTC S DGE=X I DGH>DGB,DGH<DGE S DGFL=1 Q
I 'DGFL W !,"Semi-annual assessments can only be run for April 1 and September 30.",!,"Can not complete now." H 2 G QUIT
S DGDT=DGY_""_DGAD
F R=0:0 S R=$O(^DIC(42,R)) Q:R'>0 S W0=^(R,0),S=$P(^(0),U,3) I S]"","NHI"[S S DGWD(R)=$P(W0,U)_"^"_S
F W0=0:0 S W0=$O(DGWD(W0)) Q:W0="" S DGW=$P(DGWD(W0),U),S=$P(DGWD(W0),U,2) F DFN=0:0 S DFN=$O(^DPT("CN",DGW,DFN)) Q:DFN'>0 S DGCA=^(DFN) I DGCA,$D(^DGPM(DGCA,0)),$P(^DGPM(DGCA,0),"^",2)=1 D CK S DGD=+^DGPM(DGCA,0) D FILE
PRT K W,W1,I S W=0 F W1=0:0 S W=$O(^UTILITY($J,"PAI",W)) Q:W="" D HEAD S I=0 F I1=0:0 S I=$O(^UTILITY($J,"PAI",W,I)) Q:I="" S S=0 F S1=0:0 S S=$O(^UTILITY($J,"PAI",W,I,S)) Q:S'>0 W !,I,?30,$P(^(S),"^",2),?55 S Y=+^(S) D DT^DIQ
QUIT W @IOF K %DT,A,DA,DFN,DGA1,DGAD,DGB,DGD,DGDT,DGE,DGFL,DGH,DGMD,DGN,DGCA,DGPGM,DGSEMI,DGSSN,DGT,DGY,DGVAR,DGW,DGWD,DGX,DIC,DIE,DLAYGO,DR,I,I1,J,R,S,S1,W,W0,W1,X,X1,X2,Y,^UTILITY($J) D CLOSE^DGUTQ Q
CK Q:'$D(^DGPM("ATID2",DFN)) S (DGFL,I,J)=0 F I=0:0 Q:DGFL S I=$O(^DGPM("ATID2",DFN,I)) Q:'I F J=0:0 S J=$O(^DGPM("ATID2",DFN,I,J)) Q:'J I $D(^DGPM("ATID2",DFN,I,J)),$D(^DGPM(J,0)),($P(^(0),"^",14)=DGCA) S DGFL=1,DGCA=J Q
Q
HEAD W @IOF,!,?3,$P(^DIC(42,+W,0),U),?60,"DATE: " S Y=DGDT D DT^DIQ W !!,"PATIENT ASSESSMENT INSTRUMENTS HAVE BEEN CREATED FOR THE FOLLOWING PATIENTS ",!?5,"RESIDING ON INTERMEDIATE MEDICINE WARDS OR NURSING HOME CARE UNITS"
W !?25,"DUE TO SEMI-ANNUAL CENSUS",!!,?5,"NAME",?33,"SSN",?46,"DATE OF ADMISSION/TRANSFER IN"
Q
FILE Q:$D(^DG(45.9,"AD",DFN,DGDT))
N DGWARD
S DLAYGO=45.9,DGSSN=$E($P(^DPT(DFN,0),U,9),1,9),DGN=$P(^(0),U),X=DFN
S DIC="^DG(45.9,",DIC(0)="L" D FILE^DICN G:Y'>0 BUL
S DA=+Y,DIE="^DG(45.9,",DGWARD=W0_";DIC(42,"
S DR="6///2;2////"_DGDT_";3///"_DGSSN_";7///"_DGD_";70////^S X=DGWARD;9///"_S_";80///5" D ^DIE
S ^UTILITY($J,"PAI",W0,DGN,DGSSN)=DGD_"^"_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
DATES ;;0401
;;1001
;;QUIT
EN S IOP=$S($D(ION):ION,1:"") D ^%ZIS G 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRUGSA 2536 printed Dec 13, 2024@02:58:33 Page 2
DGRUGSA ;ALB/MLI/BOK - RUG-II BACK GROUND TRIGGER FOR SEMI-ANNUAL CENSUS ; 21 JAN 88
+1 ;;5.3;Registration;**7,54,89,104**;Aug 13, 1993
+2 SET DGPGM="1^DGRUGSA"
SET DGVAR=""
DO ZIS^DGUTQ
if POP
GOTO QUIT
USE IO
DO 1
QUIT
1 SET DGSEMI=""
SET X="T"
SET %DT=""
SET U="^"
DO ^%DT
SET DGH=+Y
+1 SET DGFL=0
SET DGY=$EXTRACT(DGH,1,3)
SET DGMD=$EXTRACT(DGH,4,7)
FOR I=0:1
SET DGAD=$PIECE($TEXT(DATES+I),";;",2)
if DGAD="QUIT"
QUIT
SET X1=DGY_DGAD
SET X2=-31
DO C^%DTC
SET DGB=X
SET X1=DGY_DGAD
SET X2=31
DO C^%DTC
SET DGE=X
IF DGH>DGB
IF DGH<DGE
SET DGFL=1
QUIT
+2 IF 'DGFL
WRITE !,"Semi-annual assessments can only be run for April 1 and September 30.",!,"Can not complete now."
HANG 2
GOTO QUIT
+3 SET DGDT=DGY_""_DGAD
+4 FOR R=0:0
SET R=$ORDER(^DIC(42,R))
if R'>0
QUIT
SET W0=^(R,0)
SET S=$PIECE(^(0),U,3)
IF S]""
IF "NHI"[S
SET DGWD(R)=$PIECE(W0,U)_"^"_S
+5 FOR W0=0:0
SET W0=$ORDER(DGWD(W0))
if W0=""
QUIT
SET DGW=$PIECE(DGWD(W0),U)
SET S=$PIECE(DGWD(W0),U,2)
FOR DFN=0:0
SET DFN=$ORDER(^DPT("CN",DGW,DFN))
if DFN'>0
QUIT
SET DGCA=^(DFN)
IF DGCA
IF $DATA(^DGPM(DGCA,0))
IF $PIECE(^DGPM(DGCA,0),"^",2)=1
DO CK
SET DGD=+^DGPM(DGCA,0)
DO FILE
PRT KILL W,W1,I
SET W=0
FOR W1=0:0
SET W=$ORDER(^UTILITY($JOB,"PAI",W))
if W=""
QUIT
DO HEAD
SET I=0
FOR I1=0:0
SET I=$ORDER(^UTILITY($JOB,"PAI",W,I))
if I=""
QUIT
SET S=0
FOR S1=0:0
SET S=$ORDER(^UTILITY($JOB,"PAI",W,I,S))
if S'>0
QUIT
WRITE !,I,?30,$PIECE(^(S),"^",2),?55
SET Y=+^(S)
DO DT^DIQ
QUIT WRITE @IOF
KILL %DT,A,DA,DFN,DGA1,DGAD,DGB,DGD,DGDT,DGE,DGFL,DGH,DGMD,DGN,DGCA,DGPGM,DGSEMI,DGSSN,DGT,DGY,DGVAR,DGW,DGWD,DGX,DIC,DIE,DLAYGO,DR,I,I1,J,R,S,S1,W,W0,W1,X,X1,X2,Y,^UTILITY($JOB)
DO CLOSE^DGUTQ
QUIT
CK if '$DATA(^DGPM("ATID2",DFN))
QUIT
SET (DGFL,I,J)=0
FOR I=0:0
if DGFL
QUIT
SET I=$ORDER(^DGPM("ATID2",DFN,I))
if 'I
QUIT
FOR J=0:0
SET J=$ORDER(^DGPM("ATID2",DFN,I,J))
if 'J
QUIT
IF $DATA(^DGPM("ATID2",DFN,I,J))
IF $DATA(^DGPM(J,0))
IF ($PIECE(^(0),"^",14)=DGCA)
SET DGFL=1
SET DGCA=J
QUIT
+1 QUIT
HEAD WRITE @IOF,!,?3,$PIECE(^DIC(42,+W,0),U),?60,"DATE: "
SET Y=DGDT
DO DT^DIQ
WRITE !!,"PATIENT ASSESSMENT INSTRUMENTS HAVE BEEN CREATED FOR THE FOLLOWING PATIENTS ",!?5,"RESIDING ON INTERMEDIATE MEDICINE WARDS OR NURSING HOME CARE UNITS"
+1 WRITE !?25,"DUE TO SEMI-ANNUAL CENSUS",!!,?5,"NAME",?33,"SSN",?46,"DATE OF ADMISSION/TRANSFER IN"
+2 QUIT
FILE if $DATA(^DG(45.9,"AD",DFN,DGDT))
QUIT
+1 NEW DGWARD
+2 SET DLAYGO=45.9
SET DGSSN=$EXTRACT($PIECE(^DPT(DFN,0),U,9),1,9)
SET DGN=$PIECE(^(0),U)
SET X=DFN
+3 SET DIC="^DG(45.9,"
SET DIC(0)="L"
DO FILE^DICN
if Y'>0
GOTO BUL
+4 SET DA=+Y
SET DIE="^DG(45.9,"
SET DGWARD=W0_";DIC(42,"
+5 SET DR="6///2;2////"_DGDT_";3///"_DGSSN_";7///"_DGD_";70////^S X=DGWARD;9///"_S_";80///5"
DO ^DIE
+6 SET ^UTILITY($JOB,"PAI",W0,DGN,DGSSN)=DGD_"^"_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
DATES ;;0401
+1 ;;1001
+2 ;;QUIT
EN SET IOP=$SELECT($DATA(ION):ION,1:"")
DO ^%ZIS
GOTO 1
