- BZXLREDT ;IHS/PIMC/JLG - EDIT TABLES FOR AZ HEALTH DEPT REPORT [ 07/18/2002 2:22 PM ]
- ;;1.0;Special local routine for reportable diseases
- ENTER K DIRUT
- S DIC=1966360
- S DIC(0)="AEQMLZ"
- S DIC("A")="Enter reportable disease test: "
- S DLAYGO=1966360
- D ^DIC
- I Y=-1!$D(DIRUT) D Q
- .K DIC,DLAYGO,Y,DIROUT,DTOUT,DIRUT
- I $P(Y,U,3)="" D G ENTER:$G(BZXDELTD)
- .K BZXDELTD
- .S DIR("A")="Would you like to delete the "_Y(0,0)_" entry"
- .S DIR(0)="Y"
- .S DA=+Y
- .N Y
- .D ^DIR
- .Q:Y=0
- .W !,"Deleted!"
- .S BZXDELTD=Y
- .S DIK=DIC
- .D ^DIK
- S BZXTYPE=$P(@(U_$P(^LAB(60,$P(Y,U,2),0),U,12)_"0)"),U,2)
- S DIE=DIC
- S DA=+Y
- K DR
- I $E(BZXTYPE,1)="N" D
- .S DR=".03;.04"
- E I BZXTYPE="S" D
- .S DR="1"
- E I $E(BZXTYPE,1)="F" D
- .S DR="4"
- S DR=DR_";2//"_Y(0,0)
- D ^DIE
- G ENTER
- Q
-
- BZXLREDT ;IHS/PIMC/JLG - EDIT TABLES FOR AZ HEALTH DEPT REPORT [ 07/18/2002 2:22 PM ]
- +1 ;;1.0;Special local routine for reportable diseases
- ENTER KILL DIRUT
- +1 SET DIC=1966360
- +2 SET DIC(0)="AEQMLZ"
- +3 SET DIC("A")="Enter reportable disease test: "
- +4 SET DLAYGO=1966360
- +5 DO ^DIC
- +6 IF Y=-1!$DATA(DIRUT)
- Begin DoDot:1
- +7 KILL DIC,DLAYGO,Y,DIROUT,DTOUT,DIRUT
- End DoDot:1
- QUIT
- +8 IF $PIECE(Y,U,3)=""
- Begin DoDot:1
- +9 KILL BZXDELTD
- +10 SET DIR("A")="Would you like to delete the "_Y(0,0)_" entry"
- +11 SET DIR(0)="Y"
- +12 SET DA=+Y
- +13 NEW Y
- +14 DO ^DIR
- +15 IF Y=0
- QUIT
- +16 WRITE !,"Deleted!"
- +17 SET BZXDELTD=Y
- +18 SET DIK=DIC
- +19 DO ^DIK
- End DoDot:1
- IF $GET(BZXDELTD)
- GOTO ENTER
- +20 SET BZXTYPE=$PIECE(@(U_$PIECE(^LAB(60,$PIECE(Y,U,2),0),U,12)_"0)"),U,2)
- +21 SET DIE=DIC
- +22 SET DA=+Y
- +23 KILL DR
- +24 IF $EXTRACT(BZXTYPE,1)="N"
- Begin DoDot:1
- +25 SET DR=".03;.04"
- End DoDot:1
- +26 IF '$TEST
- IF BZXTYPE="S"
- Begin DoDot:1
- +27 SET DR="1"
- End DoDot:1
- +28 IF '$TEST
- IF $EXTRACT(BZXTYPE,1)="F"
- Begin DoDot:1
- +29 SET DR="4"
- End DoDot:1
- +30 SET DR=DR_";2//"_Y(0,0)
- +31 DO ^DIE
- +32 GOTO ENTER
- +33 QUIT
- +34
- ***** ERRORS & WARNINGS IN BZXLREDT *****
- BZXLREDT+1 S - 2nd line of routine violates the SAC.
- ENTER+34 W - Null line (no commands or comment).
