- ACKQUTL9 ;AUG/JLTP BIR/PTD HCIOFO/BH-New Clinic Visits - CONTINUED ; [ 04/12/96 10:38 AM ]
- ;;3.0;QUASAR;**1,4**;Feb 11, 2000
- ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
- ;
- BUILD() ; Generate a message informing Supervisors that time period for
- ; for changing Procedure code type has begun
- ;
- N XMDUZ,XMDUN,XMSUB,XMTEXT,XMY,TXT,X
- S (XMDUZ,XMDUN)="QUASAR",XMTEXT="TXT(",XMSUB="A&SP Procedure Code Amendment Notice"
- S TXT(1,0)=" "
- S TXT(2,0)=" This notice is to inform all Quasar Supervisors that the "
- S TXT(3,0)=" oppotunity of change the type of Procedures your Site uses"
- S TXT(4,0)=" is now available. This option will only be available until"
- S TXT(5,0)=" the 30th of September. If you wish to change the type of"
- S TXT(6,0)=" Procedure codes your Site uses select Quasars Site Parameters "
- S TXT(7,0)=" option and amend the USE EVENT CAPTURE CODES field."
- S TXT(8,0)=" "
- D STAFF,^XMD
- ;
- N ACKY
- S ZTDESC="QUASAR - Mail Procedure code Warning"
- D NOW^%DTC
- S ACKY=$E(X,1,3)
- S ACKY=ACKY+1
- S ZTDTH=ACKY_"0917.0100"
- S ZTIO=""
- S ZTRTN="BUILD^ACKQUTL9()"
- D ^%ZTLOAD
- Q
- ;
- CHANGE(ACKQQCH,ACKDA1) ; Passes in new changed value of USE EVENT CAPTURE CODE
- ; field ACKQQCH will either equal '1' or zero
- ;
- N %X,DC,D2,DE,DH,DG,DI,DICREC,DIDATA,DIEDA,DIEFDAS,DIEFCNOD,DIEFAR
- ; N DIENCNT,DIEFF,DIEFFLAG,DIEFFLD,DIEFFLST,DIEFFREF,DIEFFVAL,DIEFI
- N DIEFIEN,DIFM,DIIENS,DI0V,DIP,DIEL,DITMP,DIFLD,DIEFNVAL,DIEFNODE
- ; N DIEFLEV,DIETMP,DIEXREF,DIEFSPOT,DIEFTREF,DIEFSORK,DIEFRLST,DIEFRFLD
- ; N DIEFOVAL
- N DA,D,D0,D1,DIE,DIC,DR,DU,XMDUZ,XMDUN,XMSUB,XMTEXT,XMY,TXT,X,Z,Y
- ; N DK,DQ,DP,DQI,XQZ,X1,J,M,S,POP,DV,DW,XQXFLG,XQW,XQV,XQUSER,XQSV,XQT
- ; N XQJMP,XQCH,DOREPL,DN,DM,DLAYGO,DL,DIQUIET,DIWT,DIW,DIENS
- N ACKDIVN S ACKDIVN=$$GET1^DIQ(40.8,ACKDA1,.01)
- S (XMDUZ,XMDUN)="QUASAR",XMTEXT="TXT(",XMSUB="A&SP Procedure Code Change Notice."
- S TXT(1,0)=" "
- S TXT(2,0)=" The USE EVENT CAPTURE CODE field has been amened within "
- S TXT(3,0)=" Quasars Site Parameters function."
- S TXT(4,0)=" Division "_ACKDIVN_" is now set up to use "_$S(ACKQQCH=1:"Event Capture",1:"CPT")_" codes."
- S TXT(5,0)=" This change will take effect on the 1st of October."
- S TXT(6,0)=" "
- D STAFF,^XMD
- K ACKDA1
- Q
- ;
- STAFF ; Create XMY(... array using active supervisors from A&SP STAFF file
- N ACKQQCNV,X,Y,ACKST,ACKIND,ACKDTE S ACKST=0
- D NOW^%DTC ; X=TODAYS DATE
- S ACKDTE=X
- F S ACKST=$O(^ACK(509850.3,ACKST)) Q:'ACKST D
- . I $P(^ACK(509850.3,ACKST,0),U,6)'=1 Q ; Not a Supervisor
- . S ACKIND=$P(^ACK(509850.3,ACKST,0),U,4)
- . I ACKIND'="",ACKIND<ACKDTE Q ; Inactivated
- . S ACKQQCNV=$$CONVERT2^ACKQUTL4(ACKST) I ACKQQCNV="" Q
- . S XMY(ACKQQCNV)=""
- S XMY(DUZ)=""
- I '$O(XMY(0)) S XMY(.5)=""
- Q
- ;
- CHECK() ; Check to see if 2 week time time window to edit USE EC CODE
- ; is now
- ;
- D NOW^%DTC
- N ACKM,ACKD
- S ACKM=$E(X,4,5)
- S ACKD=$E(X,6,7)
- I ACKM'="09" Q 0
- I ACKD>16 Q 1
- Q 0
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQUTL9 3122 printed Jan 18, 2025@03:34:07 Page 2
- ACKQUTL9 ;AUG/JLTP BIR/PTD HCIOFO/BH-New Clinic Visits - CONTINUED ; [ 04/12/96 10:38 AM ]
- +1 ;;3.0;QUASAR;**1,4**;Feb 11, 2000
- +2 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
- +3 ;
- BUILD() ; Generate a message informing Supervisors that time period for
- +1 ; for changing Procedure code type has begun
- +2 ;
- +3 NEW XMDUZ,XMDUN,XMSUB,XMTEXT,XMY,TXT,X
- +4 SET (XMDUZ,XMDUN)="QUASAR"
- SET XMTEXT="TXT("
- SET XMSUB="A&SP Procedure Code Amendment Notice"
- +5 SET TXT(1,0)=" "
- +6 SET TXT(2,0)=" This notice is to inform all Quasar Supervisors that the "
- +7 SET TXT(3,0)=" oppotunity of change the type of Procedures your Site uses"
- +8 SET TXT(4,0)=" is now available. This option will only be available until"
- +9 SET TXT(5,0)=" the 30th of September. If you wish to change the type of"
- +10 SET TXT(6,0)=" Procedure codes your Site uses select Quasars Site Parameters "
- +11 SET TXT(7,0)=" option and amend the USE EVENT CAPTURE CODES field."
- +12 SET TXT(8,0)=" "
- +13 DO STAFF
- DO ^XMD
- +14 ;
- +15 NEW ACKY
- +16 SET ZTDESC="QUASAR - Mail Procedure code Warning"
- +17 DO NOW^%DTC
- +18 SET ACKY=$EXTRACT(X,1,3)
- +19 SET ACKY=ACKY+1
- +20 SET ZTDTH=ACKY_"0917.0100"
- +21 SET ZTIO=""
- +22 SET ZTRTN="BUILD^ACKQUTL9()"
- +23 DO ^%ZTLOAD
- +24 QUIT
- +25 ;
- CHANGE(ACKQQCH,ACKDA1) ; Passes in new changed value of USE EVENT CAPTURE CODE
- +1 ; field ACKQQCH will either equal '1' or zero
- +2 ;
- +3 NEW %X,DC,D2,DE,DH,DG,DI,DICREC,DIDATA,DIEDA,DIEFDAS,DIEFCNOD,DIEFAR
- +4 ; N DIENCNT,DIEFF,DIEFFLAG,DIEFFLD,DIEFFLST,DIEFFREF,DIEFFVAL,DIEFI
- +5 NEW DIEFIEN,DIFM,DIIENS,DI0V,DIP,DIEL,DITMP,DIFLD,DIEFNVAL,DIEFNODE
- +6 ; N DIEFLEV,DIETMP,DIEXREF,DIEFSPOT,DIEFTREF,DIEFSORK,DIEFRLST,DIEFRFLD
- +7 ; N DIEFOVAL
- +8 NEW DA,D,D0,D1,DIE,DIC,DR,DU,XMDUZ,XMDUN,XMSUB,XMTEXT,XMY,TXT,X,Z,Y
- +9 ; N DK,DQ,DP,DQI,XQZ,X1,J,M,S,POP,DV,DW,XQXFLG,XQW,XQV,XQUSER,XQSV,XQT
- +10 ; N XQJMP,XQCH,DOREPL,DN,DM,DLAYGO,DL,DIQUIET,DIWT,DIW,DIENS
- +11 NEW ACKDIVN
- SET ACKDIVN=$$GET1^DIQ(40.8,ACKDA1,.01)
- +12 SET (XMDUZ,XMDUN)="QUASAR"
- SET XMTEXT="TXT("
- SET XMSUB="A&SP Procedure Code Change Notice."
- +13 SET TXT(1,0)=" "
- +14 SET TXT(2,0)=" The USE EVENT CAPTURE CODE field has been amened within "
- +15 SET TXT(3,0)=" Quasars Site Parameters function."
- +16 SET TXT(4,0)=" Division "_ACKDIVN_" is now set up to use "_$SELECT(ACKQQCH=1:"Event Capture",1:"CPT")_" codes."
- +17 SET TXT(5,0)=" This change will take effect on the 1st of October."
- +18 SET TXT(6,0)=" "
- +19 DO STAFF
- DO ^XMD
- +20 KILL ACKDA1
- +21 QUIT
- +22 ;
- STAFF ; Create XMY(... array using active supervisors from A&SP STAFF file
- +1 NEW ACKQQCNV,X,Y,ACKST,ACKIND,ACKDTE
- SET ACKST=0
- +2 ; X=TODAYS DATE
- DO NOW^%DTC
- +3 SET ACKDTE=X
- +4 FOR
- SET ACKST=$ORDER(^ACK(509850.3,ACKST))
- if 'ACKST
- QUIT
- Begin DoDot:1
- +5 ; Not a Supervisor
- IF $PIECE(^ACK(509850.3,ACKST,0),U,6)'=1
- QUIT
- +6 SET ACKIND=$PIECE(^ACK(509850.3,ACKST,0),U,4)
- +7 ; Inactivated
- IF ACKIND'=""
- IF ACKIND<ACKDTE
- QUIT
- +8 SET ACKQQCNV=$$CONVERT2^ACKQUTL4(ACKST)
- IF ACKQQCNV=""
- QUIT
- +9 SET XMY(ACKQQCNV)=""
- End DoDot:1
- +10 SET XMY(DUZ)=""
- +11 IF '$ORDER(XMY(0))
- SET XMY(.5)=""
- +12 QUIT
- +13 ;
- CHECK() ; Check to see if 2 week time time window to edit USE EC CODE
- +1 ; is now
- +2 ;
- +3 DO NOW^%DTC
- +4 NEW ACKM,ACKD
- +5 SET ACKM=$EXTRACT(X,4,5)
- +6 SET ACKD=$EXTRACT(X,6,7)
- +7 IF ACKM'="09"
- QUIT 0
- +8 IF ACKD>16
- QUIT 1
- +9 QUIT 0