- DGRUGSA ;ALB/MLI/BOK - RUG-II BACK GROUND TRIGGER FOR SEMI-ANNUAL CENSUS ; 21 JAN 88
- ;;5.3;Registration;**7,54,89,104,1015**;Aug 13, 1993;Build 21
- 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
- DGRUGSA ;ALB/MLI/BOK - RUG-II BACK GROUND TRIGGER FOR SEMI-ANNUAL CENSUS ; 21 JAN 88
- +1 ;;5.3;Registration;**7,54,89,104,1015**;Aug 13, 1993;Build 21
- +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
