| 1 | FBPST35C ;AISC-CMR;ELIMINATION OF FIELDS;JUN 29, 1994
|
|---|
| 2 | ;;3.5;FEE BASIS;;JAN 30, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;FBFILE = file # with obsolete fields in it
|
|---|
| 5 | ;FBFLD = field # to be deleted
|
|---|
| 6 | ;FBGOT = set to 1 if fields still require deleting (flag to determine
|
|---|
| 7 | ; if job has previously run to completion)
|
|---|
| 8 | F I=1:1:4 S FBFILE=$P($T(FILES+I),";;",2) Q:$G(FBGOT) F J=3:1 S FBFLD=$P($T(FILES+I),";;",J) Q:'FBFLD!($G(FBGOT)) I $D(^DD(FBFILE,FBFLD,0)) S FBGOT=1
|
|---|
| 9 | I '$G(FBGOT) W "FBPST35C has previously run to completion!" G END
|
|---|
| 10 | W !!,"Beginning FBPST35C",!!?5,"REMOVAL OF FIELDS PREVIOUSLY STARRED FOR DELETION.",!!
|
|---|
| 11 | F I=1:1:13 W !,$P($T(TEXT+I),";;",2)
|
|---|
| 12 | W !! I '$D(DUZ) G START
|
|---|
| 13 | ASK S DIR(0)="Y",DIR("A")="Do you want me to task this job in the background for you",DIR("B")="Yes"
|
|---|
| 14 | S DIR("?")="Answerring 'YES' will run the job in the background and send you a bulletin",DIR("?",1)="when completed. Answerring 'NO' will run the job now (no",DIR("?",2)="bulletin will be sent)."
|
|---|
| 15 | D ^DIR K DIR I $D(DIRUT) W !!,*7,"Required response!" G ASK
|
|---|
| 16 | I Y S ZTRTN="START^FBPST35C",ZTIO="",ZTDTH=$H D ^%ZTLOAD I $D(ZTSK) W !?5,"Routine FBPST35 to remove obsolete fields has been tasked." G END
|
|---|
| 17 | START ;
|
|---|
| 18 | DATA ;delete data from obsolete fields in FB pt. file (#161)
|
|---|
| 19 | I '$D(ZTQUEUED) W !!,"Deleting any data remaining in the obsolete fields."
|
|---|
| 20 | S DFN=0 F S DFN=$O(^FBAAA(DFN)) Q:'DFN K ^FBAAA(DFN,"ADEL") S FBV=0 F S FBV=$O(^FBAAA(DFN,1,FBV)) Q:'FBV K ^FBAAA(DFN,1,FBV,"CNH")
|
|---|
| 21 | ;delete data from obsolete fields in FB vendor file (#161.2)
|
|---|
| 22 | S FBV=0 F S FBV=$O(^FBAAV(FBV)) Q:'FBV S DIE="^FBAAV(",DR="16////@;17////@;21////@",DA=FBV D ^DIE K DIE,DA,DR
|
|---|
| 23 | ;delete data from obsolete fields in FB site parameter file (#161.4)
|
|---|
| 24 | S FBSP=0 F S FBSP=$O(^FBAA(161.4,FBSP)) Q:'FBSP S DIE="^FBAA(161.4,",DR="36////@;37////@",DA=FBSP D ^DIE K DIE,DA,DR
|
|---|
| 25 | FIELDS ;remove obsolete fields
|
|---|
| 26 | F I=1:1:4 S FBFILE=$P($T(FILES+I),";;",2) F J=3:1 S FBFLD=$P($T(FILES+I),";;",J) Q:'FBFLD I $D(^DD(FBFILE,FBFLD,0)) D
|
|---|
| 27 | .I '$D(ZTQUEUED) W !!,"Deleting field # ",FBFLD," from file # ",FBFILE,"."
|
|---|
| 28 | .S DIK="^DD("_FBFILE_",",DA=FBFLD,DA(1)=FBFILE D ^DIK K DIK,DA
|
|---|
| 29 | I '$D(ZTQUEUED) W !!!,"Completed FBPST35C" G END
|
|---|
| 30 | S FBTEXT(1,0)="Post initialization routine FBPST35C has run to completion.",XMSUB="FEE BASIS POST-INIT COMPLETE",XMDUZ=.5,XMY(DUZ)="",XMTEXT="FBTEXT("
|
|---|
| 31 | D ^XMD K FBTEXT,XMSUB,XMDUZ,XMY,XMTEXT
|
|---|
| 32 | END K FBFILE,FBFLD,I,J,FBGOT,FB
|
|---|
| 33 | Q
|
|---|
| 34 | FILES ;;
|
|---|
| 35 | ;;161.01;;4
|
|---|
| 36 | ;;161;;102;;103;;104
|
|---|
| 37 | ;;161.2;;16;;17;;21
|
|---|
| 38 | ;;161.4;;36;;37
|
|---|
| 39 | TEXT ;;
|
|---|
| 40 | ;;I will now remove the following fields that have been starred for
|
|---|
| 41 | ;;deletion:
|
|---|
| 42 | ;; File Field
|
|---|
| 43 | ;; ---- -----
|
|---|
| 44 | ;; 161 Fee Basis Patient 102 *AUSTIN DELETED
|
|---|
| 45 | ;; 103 *DATE OF AUSTIN DELETE
|
|---|
| 46 | ;; 104 *DATE TRANSMITTED TO AUSTIN
|
|---|
| 47 | ;; 161.01 Fee Basis Patient 4 *CNH LEVEL OF CARE
|
|---|
| 48 | ;; 161.2 Fee Basis Vendor 16 *NUMBER OF SKILLED BEDS
|
|---|
| 49 | ;; 17 *NUMBER OF INTERMEDIATE BEDS
|
|---|
| 50 | ;; 21 *LEVELS OF CARE PROVIDED
|
|---|
| 51 | ;; 161.4 Fee Basis Site Parameters 36 *LAST UC UPDATED
|
|---|
| 52 | ;; 37 *DATE UC CONVERSION COMPLETED
|
|---|
