- NURAAU3 ;HIRMFO/RM,MD-PURGE MODULE...AMIS A1106 ;2/27/98 14:20
- ;;4.0;NURSING SERVICE;**9**;Apr 25, 1997
- ; LAST MODIFIED BY MD;/10/26/92
- ; DONE BY: NURAAU0
- EN1 ; PURGE AMIS ACUITY DATA
- ; PURGE YEARLY (RETAIN 4 FISCAL YEARS) FROM FILE 213.4
- ;
- S NURPLSW=1
- S PURGDATE=($E(DT,1,3)-4)_"1001" S REC="" F NURSI=0:0 S REC=$O(^NURSA(213.4,"B",REC)) Q:'($E(REC,1,7)<PURGDATE) S DA=$O(^NURSA(213.4,"B",REC,0)),DIK="^NURSA(213.4," W:'$D(ZTQUEUED) "." D ^DIK
- K NURPLSW Q
- EXCP ; FILE EXCEPTION REPORT DATA
- I $S(NURTYPE=1:1,1:0) G 1
- S:'$D(^NURSA(213.5,NEXCDA,1,0)) ^NURSA(213.5,NEXCDA,1,0)="^213.51P^^"
- S ^NURSA(213.5,NEXCDA,1,DFN,0)=DFN_"^"_NWARD,$P(^NURSA(213.5,NEXCDA,1,0),"^",3,4)=DFN_"^"_($P(^NURSA(213.5,NEXCDA,1,0),"^",4)+1),DA(1)=NEXCDA,DA=DFN,DIK="^NURSA(213.5,DA(1),1," D IX1^DIK
- S DIE="^NURSA(213.5,DA(1),1,",DR="2///^S X=NERR;3///^S X=NURSX;4///^S X=CLSDATE" D ^DIE Q
- 1 Q:NERR(1)="" S:'$D(^NURSA(213.5,NEXCDA(1),1,0)) ^NURSA(213.5,NEXCDA(1),1,0)="^213.51P^^"
- S ^NURSA(213.5,NEXCDA(1),1,DFN,0)=DFN_"^"_NWARD,$P(^NURSA(213.5,NEXCDA(1),1,0),"^",3,4)=DFN_"^"_($P(^NURSA(213.5,NEXCDA(1),1,0),"^",4)+1),DA(1)=NEXCDA(1),DA=DFN,DIK="^NURSA(213.5,DA(1),1," D IX1^DIK
- S DIE="^NURSA(213.5,DA(1),1,",DR="2///^S X=NERR(1);3///^S X=NURSX;4///^S X=CLSDATE" D ^DIE
- Q
- EN2 ; ENTRY TO PURGE FILE 213.5 DATA OLDER THAN 30 DAYS AND CREATE TODAYS NODES
- S X="T-30",%DT="" D ^%DT S NURSJ=+Y
- S DIK="^NURSA(213.5," F NURSI=0:0 S NURSI=$O(^NURSA(213.5,"B",NURSI)) Q:NURSI'>0 F DA=0:0 S DA=$O(^NURSA(213.5,"B",NURSI,DA)) Q:DA'>0 I '(NURSI>NURSJ) W:'$D(ZTQUEUED) "." D ^DIK
- L +^NURSA(213.5)
- F NURTYPE=0,1 S X=RPTDATE,DLAYGO=213.5,DIC="^NURSA(213.5,",DIC(0)="L",DIC("DR")=".02///^S X=NURTYPE",DIC("S")="I $P(^(0),U,2)=NURTYPE" D ^DIC K DIC,DLAYGO S:NURTYPE=0 NEXCDA=+Y S:NURTYPE=1 NEXCDA(1)=+Y
- L -^NURSA(213.5) S:+Y'>0 NUROUTSW=1 Q:NUROUTSW
- K NURTYPE
- Q
- HEMCOUNT ; HEMODIALYSIS COUNT UPDATE
- S BEDSECT=$O(^NURSF(213.3,"B","HEMODIALYSIS","")),NURS1=0
- I $L(BEDSECT)=1 S BEDSECT="0"_BEDSECT
- F NCWARD=0:0 S NCWARD=$O(^NURSA(214.6,"ACNT",RPTDATE,NCWARD)) Q:NCWARD'>0 F NURSI=0:0 S NURSI=$O(^NURSA(214.6,"ACNT",RPTDATE,NCWARD,"H",NURSI)) Q:NURSI'>0 S NURS1=NURS1+1 D HMRCPROC S NURS1=0
- Q
- RECOUNT ; RECOVERY ROOM COUNT UPDATE
- S BEDSECT=$O(^NURSF(213.3,"B","RECOVERY ROOM","")),NURS1=0
- I $L(BEDSECT)=1 S BEDSECT="0"_BEDSECT
- F NCWARD=0:0 S NCWARD=$O(^NURSA(214.6,"ACNT",RPTDATE,NCWARD)) Q:NCWARD'>0 F NURSI=0:0 S NURSI=$O(^NURSA(214.6,"ACNT",RPTDATE,NCWARD,"R",NURSI)) Q:NURSI'>0 S NURS1=NURS1+1 D HMRCPROC S NURS1=0
- Q
- HMRCPROC ; PROCESS RECOVERY/ROOM AND HEMODALYSIS COUNTS
- S REC=RPTDATE_BEDSECT_NCWARD F I=1:1:5 S NCLASS(I)=0
- S NCLASS(1)=NURS1 D FINALLY^NURAAU0
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURAAU3 2704 printed Mar 13, 2025@21:23:53 Page 2
- NURAAU3 ;HIRMFO/RM,MD-PURGE MODULE...AMIS A1106 ;2/27/98 14:20
- +1 ;;4.0;NURSING SERVICE;**9**;Apr 25, 1997
- +2 ; LAST MODIFIED BY MD;/10/26/92
- +3 ; DONE BY: NURAAU0
- EN1 ; PURGE AMIS ACUITY DATA
- +1 ; PURGE YEARLY (RETAIN 4 FISCAL YEARS) FROM FILE 213.4
- +2 ;
- +3 SET NURPLSW=1
- +4 SET PURGDATE=($EXTRACT(DT,1,3)-4)_"1001"
- SET REC=""
- FOR NURSI=0:0
- SET REC=$ORDER(^NURSA(213.4,"B",REC))
- if '($EXTRACT(REC,1,7)<PURGDATE)
- QUIT
- SET DA=$ORDER(^NURSA(213.4,"B",REC,0))
- SET DIK="^NURSA(213.4,"
- if '$DATA(ZTQUEUED)
- WRITE "."
- DO ^DIK
- +5 KILL NURPLSW
- QUIT
- EXCP ; FILE EXCEPTION REPORT DATA
- +1 IF $SELECT(NURTYPE=1:1,1:0)
- GOTO 1
- +2 if '$DATA(^NURSA(213.5,NEXCDA,1,0))
- SET ^NURSA(213.5,NEXCDA,1,0)="^213.51P^^"
- +3 SET ^NURSA(213.5,NEXCDA,1,DFN,0)=DFN_"^"_NWARD
- SET $PIECE(^NURSA(213.5,NEXCDA,1,0),"^",3,4)=DFN_"^"_($PIECE(^NURSA(213.5,NEXCDA,1,0),"^",4)+1)
- SET DA(1)=NEXCDA
- SET DA=DFN
- SET DIK="^NURSA(213.5,DA(1),1,"
- DO IX1^DIK
- +4 SET DIE="^NURSA(213.5,DA(1),1,"
- SET DR="2///^S X=NERR;3///^S X=NURSX;4///^S X=CLSDATE"
- DO ^DIE
- QUIT
- 1 if NERR(1)=""
- QUIT
- if '$DATA(^NURSA(213.5,NEXCDA(1),1,0))
- SET ^NURSA(213.5,NEXCDA(1),1,0)="^213.51P^^"
- +1 SET ^NURSA(213.5,NEXCDA(1),1,DFN,0)=DFN_"^"_NWARD
- SET $PIECE(^NURSA(213.5,NEXCDA(1),1,0),"^",3,4)=DFN_"^"_($PIECE(^NURSA(213.5,NEXCDA(1),1,0),"^",4)+1)
- SET DA(1)=NEXCDA(1)
- SET DA=DFN
- SET DIK="^NURSA(213.5,DA(1),1,"
- DO IX1^DIK
- +2 SET DIE="^NURSA(213.5,DA(1),1,"
- SET DR="2///^S X=NERR(1);3///^S X=NURSX;4///^S X=CLSDATE"
- DO ^DIE
- +3 QUIT
- EN2 ; ENTRY TO PURGE FILE 213.5 DATA OLDER THAN 30 DAYS AND CREATE TODAYS NODES
- +1 SET X="T-30"
- SET %DT=""
- DO ^%DT
- SET NURSJ=+Y
- +2 SET DIK="^NURSA(213.5,"
- FOR NURSI=0:0
- SET NURSI=$ORDER(^NURSA(213.5,"B",NURSI))
- if NURSI'>0
- QUIT
- FOR DA=0:0
- SET DA=$ORDER(^NURSA(213.5,"B",NURSI,DA))
- if DA'>0
- QUIT
- IF '(NURSI>NURSJ)
- if '$DATA(ZTQUEUED)
- WRITE "."
- DO ^DIK
- +3 LOCK +^NURSA(213.5)
- +4 FOR NURTYPE=0,1
- SET X=RPTDATE
- SET DLAYGO=213.5
- SET DIC="^NURSA(213.5,"
- SET DIC(0)="L"
- SET DIC("DR")=".02///^S X=NURTYPE"
- SET DIC("S")="I $P(^(0),U,2)=NURTYPE"
- DO ^DIC
- KILL DIC,DLAYGO
- if NURTYPE=0
- SET NEXCDA=+Y
- if NURTYPE=1
- SET NEXCDA(1)=+Y
- +5 LOCK -^NURSA(213.5)
- if +Y'>0
- SET NUROUTSW=1
- if NUROUTSW
- QUIT
- +6 KILL NURTYPE
- +7 QUIT
- HEMCOUNT ; HEMODIALYSIS COUNT UPDATE
- +1 SET BEDSECT=$ORDER(^NURSF(213.3,"B","HEMODIALYSIS",""))
- SET NURS1=0
- +2 IF $LENGTH(BEDSECT)=1
- SET BEDSECT="0"_BEDSECT
- +3 FOR NCWARD=0:0
- SET NCWARD=$ORDER(^NURSA(214.6,"ACNT",RPTDATE,NCWARD))
- if NCWARD'>0
- QUIT
- FOR NURSI=0:0
- SET NURSI=$ORDER(^NURSA(214.6,"ACNT",RPTDATE,NCWARD,"H",NURSI))
- if NURSI'>0
- QUIT
- SET NURS1=NURS1+1
- DO HMRCPROC
- SET NURS1=0
- +4 QUIT
- RECOUNT ; RECOVERY ROOM COUNT UPDATE
- +1 SET BEDSECT=$ORDER(^NURSF(213.3,"B","RECOVERY ROOM",""))
- SET NURS1=0
- +2 IF $LENGTH(BEDSECT)=1
- SET BEDSECT="0"_BEDSECT
- +3 FOR NCWARD=0:0
- SET NCWARD=$ORDER(^NURSA(214.6,"ACNT",RPTDATE,NCWARD))
- if NCWARD'>0
- QUIT
- FOR NURSI=0:0
- SET NURSI=$ORDER(^NURSA(214.6,"ACNT",RPTDATE,NCWARD,"R",NURSI))
- if NURSI'>0
- QUIT
- SET NURS1=NURS1+1
- DO HMRCPROC
- SET NURS1=0
- +4 QUIT
- HMRCPROC ; PROCESS RECOVERY/ROOM AND HEMODALYSIS COUNTS
- +1 SET REC=RPTDATE_BEDSECT_NCWARD
- FOR I=1:1:5
- SET NCLASS(I)=0
- +2 SET NCLASS(1)=NURS1
- DO FINALLY^NURAAU0
- +3 QUIT
