- ACKQUTL1 ;HCIOFO/BH-Utilities ; [ 04/12/96 10:38 AM ]
- ;;3.0;QUASAR;**1**;Feb 11, 2000
- ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
- ;
- EVENT(ACKDIV) ; It has to be between 17th and 30th of september to use this option
- I '$$CHECK^ACKQUTL9() Q
- N DIR,Y,ACKEC,ACKY,ACKKEY,X
- ; DISPLAY WARNING HERE
- ;
- ; Give user option to quit
- W !!!
- W "Warning - The following field allows Supervisors to amend the type of Procedure"
- W !," codes used within a particular Division for the coming DSS extract"
- W !," period. This option is only made available between the 17th & 30th"
- W !," of September each year. Users will be able to re-edit this"
- W !," field within this time period but all values after the 30th of"
- W !," September will be final for the approaching Fiscal Year !"
- W !!!
- S DIR(0)="Y"
- S DIR("?")="Enter 'Yes' if you wish to continue or 'No' to Quit."
- S DIR("A")="Do you wish to continue."
- S DIR("B")="NO" W ! D ^DIR K DIR
- I Y=0 Q
- ;
- N ACKPRAM S ACKPRAM=""
- D NOW^%DTC
- S ACKY=$E(X,2,3) S ACKY=ACKY+1 I $L(ACKY)=1 S ACKY="0"_ACKY
- I '$D(^ACK(509850.8,1,2,ACKDIV,2,"B",ACKY)) D
- . N ACKARR1,ACKCIEN S ACKCIEN="",ACKPRAM="INIT"
- . S ACKARR1(509850.832,"+1,"_ACKDIV_",1,",.01)=ACKY
- . ; S ACKARR1(509850.832,"+1,"_ACKDIV_",1,",2)="0"
- . D UPDATE^DIE("","ACKARR1","ACKCIEN","ERR")
- . ;
- S ACKKEY=0
- S ACKKEY=$O(^ACK(509850.8,1,2,ACKDIV,2,"B",ACKY,ACKKEY))
- S ACKEC=$P(^ACK(509850.8,1,2,ACKDIV,2,ACKKEY,0),"^",2)
- I ACKEC="" S ACKEC="0"
- ;
- W !!
- S DIR(0)="Y"
- S DIR("?")="Answer 'YES' if you want this Division to use Event Capture codes or 'No' if you want this Division to use CPT codes."
- S DIR("A")="USE EVENT CAPTURE CODES"
- S DIR("B")="NO" I ACKEC=1 S DIR("B")="YES"
- D ^DIR K DIR
- I Y'=ACKEC!(ACKPRAM="INIT") D
- . N ACKARR
- . S ACKARR(509850.832,ACKKEY_","_ACKDIV_",1,",2)=Y D FILE^DIE("","ACKARR",)
- . ; S $P(^ACK(509850.8,1,2,ACKDIV,2,ACKKEY,0),"^",2)=Y
- W !!
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQUTL1 2011 printed Jan 18, 2025@03:34 Page 2
- ACKQUTL1 ;HCIOFO/BH-Utilities ; [ 04/12/96 10:38 AM ]
- +1 ;;3.0;QUASAR;**1**;Feb 11, 2000
- +2 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
- +3 ;
- EVENT(ACKDIV) ; It has to be between 17th and 30th of september to use this option
- +1 IF '$$CHECK^ACKQUTL9()
- QUIT
- +2 NEW DIR,Y,ACKEC,ACKY,ACKKEY,X
- +3 ; DISPLAY WARNING HERE
- +4 ;
- +5 ; Give user option to quit
- +6 WRITE !!!
- +7 WRITE "Warning - The following field allows Supervisors to amend the type of Procedure"
- +8 WRITE !," codes used within a particular Division for the coming DSS extract"
- +9 WRITE !," period. This option is only made available between the 17th & 30th"
- +10 WRITE !," of September each year. Users will be able to re-edit this"
- +11 WRITE !," field within this time period but all values after the 30th of"
- +12 WRITE !," September will be final for the approaching Fiscal Year !"
- +13 WRITE !!!
- +14 SET DIR(0)="Y"
- +15 SET DIR("?")="Enter 'Yes' if you wish to continue or 'No' to Quit."
- +16 SET DIR("A")="Do you wish to continue."
- +17 SET DIR("B")="NO"
- WRITE !
- DO ^DIR
- KILL DIR
- +18 IF Y=0
- QUIT
- +19 ;
- +20 NEW ACKPRAM
- SET ACKPRAM=""
- +21 DO NOW^%DTC
- +22 SET ACKY=$EXTRACT(X,2,3)
- SET ACKY=ACKY+1
- IF $LENGTH(ACKY)=1
- SET ACKY="0"_ACKY
- +23 IF '$DATA(^ACK(509850.8,1,2,ACKDIV,2,"B",ACKY))
- Begin DoDot:1
- +24 NEW ACKARR1,ACKCIEN
- SET ACKCIEN=""
- SET ACKPRAM="INIT"
- +25 SET ACKARR1(509850.832,"+1,"_ACKDIV_",1,",.01)=ACKY
- +26 ; S ACKARR1(509850.832,"+1,"_ACKDIV_",1,",2)="0"
- +27 DO UPDATE^DIE("","ACKARR1","ACKCIEN","ERR")
- +28 ;
- End DoDot:1
- +29 SET ACKKEY=0
- +30 SET ACKKEY=$ORDER(^ACK(509850.8,1,2,ACKDIV,2,"B",ACKY,ACKKEY))
- +31 SET ACKEC=$PIECE(^ACK(509850.8,1,2,ACKDIV,2,ACKKEY,0),"^",2)
- +32 IF ACKEC=""
- SET ACKEC="0"
- +33 ;
- +34 WRITE !!
- +35 SET DIR(0)="Y"
- +36 SET DIR("?")="Answer 'YES' if you want this Division to use Event Capture codes or 'No' if you want this Division to use CPT codes."
- +37 SET DIR("A")="USE EVENT CAPTURE CODES"
- +38 SET DIR("B")="NO"
- IF ACKEC=1
- SET DIR("B")="YES"
- +39 DO ^DIR
- KILL DIR
- +40 IF Y'=ACKEC!(ACKPRAM="INIT")
- Begin DoDot:1
- +41 NEW ACKARR
- +42 SET ACKARR(509850.832,ACKKEY_","_ACKDIV_",1,",2)=Y
- DO FILE^DIE("","ACKARR",)
- +43 ; S $P(^ACK(509850.8,1,2,ACKDIV,2,ACKKEY,0),"^",2)=Y
- End DoDot:1
- +44 WRITE !!
- +45 QUIT
- +46 ;