- DVBARPUR ;557/THM-PURGE AMIE FILES ;21 JUL 89
- ;;2.7;AMIE;;Apr 10, 1995
- ;NOTE: This program was designed to run on the TaskManager. There is
- ; no output at all. It will, however, run real-time, if desired.
- ;
- SETUP D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) EXIT ;no parameters set
- I '$D(DT) S X="T" D ^%DT S DT=Y
- ;
- PART1 ;for 7131 file--^DVB(396,
- S HIST=$S($P(^DVB(396.1,1,0),U,10)]"":$P(^(0),U,10),1:60) ;IF NOTHING SET, KEEP 60 DAYS
- D DATE
- GO S MA="" F I=0:0 S MA=$O(^DVB(396,"F",MA)) Q:MA="" S MB="" F J=0:0 S MB=$O(^DVB(396,"F",MA,MB)) Q:MB="" D KILL
- D PART2
- ;
- EXIT K DVBAQUIT,NODE,DIK,X,Y,MA,MB,I,J,DA,PDATE,X1,X2,HIST,%,%DT,%H,LOC
- Q
- ;
- KILL I '$D(^DVB(396,MB,0)) K ^DVB(396,"F",MA,MB)
- I $D(^DVB(396,MB,0)) DO
- .S X1=PDATE,X2=MA D ^%DTC I X>0 S DA=MB,DIK="^DVB(396," D ^DIK K DIK,DA
- Q
- DATE S X1=DT,X2=HIST,X2=-X2 D C^%DTC S PDATE=X
- Q
- PART2 ;for NOTICE OF DISCHARGE file--^DVB(396.2
- S HIST=30 D DATE
- F LOC=0:0 S LOC=$O(^DVB(396.2,"C",LOC)) Q:LOC="" F NODE=0:0 S NODE=$O(^DVB(396.2,"C",LOC,"P",NODE)) Q:NODE="" D KILL2
- Q
- ;
- KILL2 I '$D(^DVB(396.2,NODE)) K ^DVB(396.2,"C",LOC,"P",NODE) Q
- S X1=PDATE,X2=$P(^DVB(396.2,NODE,0),U,5) D ^%DTC I X>0 S DA=NODE,DIK="^DVB(396.2," D ^DIK K DIK,DA
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBARPUR 1245 printed Jan 18, 2025@02:43:21 Page 2
- DVBARPUR ;557/THM-PURGE AMIE FILES ;21 JUL 89
- +1 ;;2.7;AMIE;;Apr 10, 1995
- +2 ;NOTE: This program was designed to run on the TaskManager. There is
- +3 ; no output at all. It will, however, run real-time, if desired.
- +4 ;
- SETUP ;no parameters set
- DO NOPARM^DVBAUTL2
- if $DATA(DVBAQUIT)
- GOTO EXIT
- +1 IF '$DATA(DT)
- SET X="T"
- DO ^%DT
- SET DT=Y
- +2 ;
- PART1 ;for 7131 file--^DVB(396,
- +1 ;IF NOTHING SET, KEEP 60 DAYS
- SET HIST=$SELECT($PIECE(^DVB(396.1,1,0),U,10)]"":$PIECE(^(0),U,10),1:60)
- +2 DO DATE
- GO SET MA=""
- FOR I=0:0
- SET MA=$ORDER(^DVB(396,"F",MA))
- if MA=""
- QUIT
- SET MB=""
- FOR J=0:0
- SET MB=$ORDER(^DVB(396,"F",MA,MB))
- if MB=""
- QUIT
- DO KILL
- +1 DO PART2
- +2 ;
- EXIT KILL DVBAQUIT,NODE,DIK,X,Y,MA,MB,I,J,DA,PDATE,X1,X2,HIST,%,%DT,%H,LOC
- +1 QUIT
- +2 ;
- KILL IF '$DATA(^DVB(396,MB,0))
- KILL ^DVB(396,"F",MA,MB)
- +1 IF $DATA(^DVB(396,MB,0))
- Begin DoDot:1
- +2 SET X1=PDATE
- SET X2=MA
- DO ^%DTC
- IF X>0
- SET DA=MB
- SET DIK="^DVB(396,"
- DO ^DIK
- KILL DIK,DA
- End DoDot:1
- +3 QUIT
- DATE SET X1=DT
- SET X2=HIST
- SET X2=-X2
- DO C^%DTC
- SET PDATE=X
- +1 QUIT
- PART2 ;for NOTICE OF DISCHARGE file--^DVB(396.2
- +1 SET HIST=30
- DO DATE
- +2 FOR LOC=0:0
- SET LOC=$ORDER(^DVB(396.2,"C",LOC))
- if LOC=""
- QUIT
- FOR NODE=0:0
- SET NODE=$ORDER(^DVB(396.2,"C",LOC,"P",NODE))
- if NODE=""
- QUIT
- DO KILL2
- +3 QUIT
- +4 ;
- KILL2 IF '$DATA(^DVB(396.2,NODE))
- KILL ^DVB(396.2,"C",LOC,"P",NODE)
- QUIT
- +1 SET X1=PDATE
- SET X2=$PIECE(^DVB(396.2,NODE,0),U,5)
- DO ^%DTC
- IF X>0
- SET DA=NODE
- SET DIK="^DVB(396.2,"
- DO ^DIK
- KILL DIK,DA
- +2 QUIT