ACKQCLED ;SMT - ACKQ CLINICIAN EDIT MENU ;11/14/07 10:24am ; 9/22/09 8:48am
;;3.0;QUASAR;**17**;Nov 10, 2007;Build 28
Q
; ACKQ*3*17 Removed the pointer from the .01 field of file 509850.3
; to the .01 field of file 200. Because of this, Adding a new A&SP
; staff member can be done with ^A at the lookup prompt.
;
;
EN ;Menu Entry Point.
N X,Y,DIC,DR,DTOUT,DUOUT,DIE,ACKIEN,ADDFLG
K RSLT
;
SRCH ;Search New Person file for a name
S DIC="^ACK(509850.3,",DIC(0)="QAME",DIC("A")="Select A&SP STAFF NAME (^A to add new entry):"
W !
D ^DIC
I X["^A" G ADDSTF
I $D(DTOUT)!$D(DUOUT)!(Y<0) G EX
S ACKIEN=$O(^ACK(509850.3,"B",$P(Y,"^",2),0)),RSLT=Y,ADDFLG=0
G EDTSTF
Q
;
ADDSTF ;Add A&SP Staff Member
N ANS,PCK,UCK
K DIC S DIC="^VA(200,",DIC(0)="AQME"
D ^DIC
I $D(DTOUT)!$D(DUOUT)!(Y<0) G SRCH
I $O(^ACK(509850.3,"B",$P(Y,"^",2),0)) W !,$P(Y,"^",2)_" is already an A&SP Staff Member" G ADDSTF
S ACKLAYGO="",%=2,RSLT=Y
W !,"Are you adding "_$P(RSLT,"^",2)_" as a new A&SP Staff" D YN^DICN S ANS=% G:ANS=2 ADDSTF
S PCK=$$PCCHK(+RSLT),UCK=$$USRCHK($P(RSLT,"^",2))
I (PCK<1) W !,$P(RSLT,"^",2)_$S(PCK=-1:" has no PERSON CLASS, status will be set to STUDENT.",1:" needs a valid PERSON CLASS.") S:PCK=0 ANS=2
I (UCK=0) W !,$P(RSLT,"^",2)_" needs a valid USR CLASS." S ANS=2
I ANS=2 G ADDSTF
I ANS=1 D
. S ADDFLG=1,DIC="^ACK(509850.3,",X=$P(RSLT,"^",2)
. S DIC("DR")=".07////^S X=+RSLT" S:(PCK=-1) DIC("DR")=DIC("DR")_";.02//S;.06//0"
. D FILE^DICN
. I Y=-1 W "ERROR" Q
G:Y=-1 EX
S ACKIEN=$P(Y,"^") G EDTSTF
Q
;
EDTSTF ;Edit an A&SP Staff Member.
; Force User with No PERSON CLASS to remain student.
;
N PCK,UCK
D NOW^%DTC S TODAY=$P(%,".")
S DIE="^ACK(509850.3,",DA=ACKIEN
D DO^DIC1 S ID=$S(+$P(^ACK(509850.3,DA,0),"^",5):$P(^ACK(509850.3,DA,0),"^",5),1:$G(^ACK(509850.3,"ALID"))+1)
S PCK=$$PCCHK($$GET1^DIQ(509850.3,DA,.07,"I")),UCK=$$USRCHK($$GET1^DIQ(509850.3,DA,.01,"E"))
S DR=$S(PCK<1:".02///S;",1:".02;")_".03;"_$S('UCK:".04///^S X=TODAY-1",1:".04")_";.05//^S X=$E(""0000"",1,4-$L(ID))_ID;"_$S(PCK<1:".06///0",1:".06")
;If this is a newly added user, we don't need double alerts.
I 'ADDFLG D
. W:PCK<1 !,"No Valid/Active PERSON CLASS, STATUS forced to STUDENT"
. W:'UCK !," No Valid USR CLASS, User forced INACTIVE."
. Q
D ^DIE
G SRCH
Q
;
NMVD ;Validate that the NEW PERSON names match the A&SP Staff names,
;If the NEW PERSON name was changed, The A&SP Name will be changed to match
N NPIEN,NPNM,I,DIK
S I=0,DIK="^ACK(509850.3,",DIK(1)=".01^B" F S I=$O(^ACK(509850.3,I)) Q:'I D
. S NPIEN=$P(^ACK(509850.3,I,1),"^"),NPNM=$$GET1^DIQ(200,NPIEN,.01,"")
. I $P(^ACK(509850.3,I,0),"^")=NPNM Q
. K ^ACK(509850.3,"B",$P(^ACK(509850.3,I,0),"^"),I)
. S $P(^ACK(509850.3,I,0),"^")=NPNM,DA=I
. D EN1^DIK
Q
;
PCCHK(NPIEN) ;Check if User has a PERSON CLASS valid to QUASAR.
; Input:
; NPIEN = New Person File IEN
; Output:
; 1 - if Audiology/Valid Quasra person class exists and is active
; 0 - No valid Quasar person class exists or is active(can be student)
; -1 - No Person classes assigned to this user(can be student)
;
N I,EFDT,EXPDT,X,RETRN,TODAY,PCLS
S RETRN=0,PCLS=""
D NOW^%DTC S TODAY=$P(%,".")
F I=1:1 K ACKQARY D GETS^DIQ(200.05,I_","_NPIEN,".01;2:3","I","ACKQARY") Q:'$D(ACKQARY) D
. ;Unimplemented checks (Possible future use?)
. ;S PCLS=$$GET1^DIQ(8932.1,$G(ACKQARY(200.05,I_","_NPIEN_",",.01,"I")),5,"") Q:(I=1)&(PCLS="")
. ;I '((PCLS["V140200")!(PCLS["V140701")!(PCLS["V140600")!(PCLS["V140500")) Q
. S EFDT=$G(ACKQARY(200.05,I_","_NPIEN_",",2,"I")),EXPDT=$G(ACKQARY(200.05,I_","_NPIEN_",",3,"I"))
. I (EFDT<=TODAY),(+EXPDT=0)!(EXPDT>TODAY) S RETRN=1
K ACKQARY
I I=1,PCLS="" Q -1
Q RETRN
;
USRCHK(NPNM) ;Check if User has valid USR Class
; Input:
; NPNM = FILE 200 NAME
; Output:
; Returns 1 if Valid, 0 if invalid.
;
N USRARY,I,RETRN,TODAY,USRIEN
D NOW^%DTC S RETRN=0,TODAY=$P(%,".")
K USRARY D FIND^DIC(8930.3,"",".01","",NPNM,"","B","","","USRARY")
S I=0 F S I=$O(USRARY("DILIST",2,I)) Q:'I!RETRN D
. S RETRN=1,USRIEN=USRARY("DILIST",2,I)
. I +$$GET1^DIQ(8930.3,USRIEN,".03","I")>TODAY S RETRN=0
. I +$$GET1^DIQ(8930.3,USRIEN,".04","I")<=TODAY,+$$GET1^DIQ(8930.3,USRIEN,".04","I")>0 S RETRN=0
Q RETRN
;
EX K DIC,DIK,DIE,DR,X,Y,RSLT,ACKIEN,USRARY,ACKQARY,TODAY,RETRN,ID
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQCLED 4412 printed Sep 23, 2025@20:08:23 Page 2
ACKQCLED ;SMT - ACKQ CLINICIAN EDIT MENU ;11/14/07 10:24am ; 9/22/09 8:48am
+1 ;;3.0;QUASAR;**17**;Nov 10, 2007;Build 28
+2 QUIT
+3 ; ACKQ*3*17 Removed the pointer from the .01 field of file 509850.3
+4 ; to the .01 field of file 200. Because of this, Adding a new A&SP
+5 ; staff member can be done with ^A at the lookup prompt.
+6 ;
+7 ;
EN ;Menu Entry Point.
+1 NEW X,Y,DIC,DR,DTOUT,DUOUT,DIE,ACKIEN,ADDFLG
+2 KILL RSLT
+3 ;
SRCH ;Search New Person file for a name
+1 SET DIC="^ACK(509850.3,"
SET DIC(0)="QAME"
SET DIC("A")="Select A&SP STAFF NAME (^A to add new entry):"
+2 WRITE !
+3 DO ^DIC
+4 IF X["^A"
GOTO ADDSTF
+5 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<0)
GOTO EX
+6 SET ACKIEN=$ORDER(^ACK(509850.3,"B",$PIECE(Y,"^",2),0))
SET RSLT=Y
SET ADDFLG=0
+7 GOTO EDTSTF
+8 QUIT
+9 ;
ADDSTF ;Add A&SP Staff Member
+1 NEW ANS,PCK,UCK
+2 KILL DIC
SET DIC="^VA(200,"
SET DIC(0)="AQME"
+3 DO ^DIC
+4 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<0)
GOTO SRCH
+5 IF $ORDER(^ACK(509850.3,"B",$PIECE(Y,"^",2),0))
WRITE !,$PIECE(Y,"^",2)_" is already an A&SP Staff Member"
GOTO ADDSTF
+6 SET ACKLAYGO=""
SET %=2
SET RSLT=Y
+7 WRITE !,"Are you adding "_$PIECE(RSLT,"^",2)_" as a new A&SP Staff"
DO YN^DICN
SET ANS=%
if ANS=2
GOTO ADDSTF
+8 SET PCK=$$PCCHK(+RSLT)
SET UCK=$$USRCHK($PIECE(RSLT,"^",2))
+9 IF (PCK<1)
WRITE !,$PIECE(RSLT,"^",2)_$SELECT(PCK=-1:" has no PERSON CLASS, status will be set to STUDENT.",1:" needs a valid PERSON CLASS.")
if PCK=0
SET ANS=2
+10 IF (UCK=0)
WRITE !,$PIECE(RSLT,"^",2)_" needs a valid USR CLASS."
SET ANS=2
+11 IF ANS=2
GOTO ADDSTF
+12 IF ANS=1
Begin DoDot:1
+13 SET ADDFLG=1
SET DIC="^ACK(509850.3,"
SET X=$PIECE(RSLT,"^",2)
+14 SET DIC("DR")=".07////^S X=+RSLT"
if (PCK=-1)
SET DIC("DR")=DIC("DR")_";.02//S;.06//0"
+15 DO FILE^DICN
+16 IF Y=-1
WRITE "ERROR"
QUIT
End DoDot:1
+17 if Y=-1
GOTO EX
+18 SET ACKIEN=$PIECE(Y,"^")
GOTO EDTSTF
+19 QUIT
+20 ;
EDTSTF ;Edit an A&SP Staff Member.
+1 ; Force User with No PERSON CLASS to remain student.
+2 ;
+3 NEW PCK,UCK
+4 DO NOW^%DTC
SET TODAY=$PIECE(%,".")
+5 SET DIE="^ACK(509850.3,"
SET DA=ACKIEN
+6 DO DO^DIC1
SET ID=$SELECT(+$PIECE(^ACK(509850.3,DA,0),"^",5):$PIECE(^ACK(509850.3,DA,0),"^",5),1:$GET(^ACK(509850.3,"ALID"))+1)
+7 SET PCK=$$PCCHK($$GET1^DIQ(509850.3,DA,.07,"I"))
SET UCK=$$USRCHK($$GET1^DIQ(509850.3,DA,.01,"E"))
+8 SET DR=$SELECT(PCK<1:".02///S;",1:".02;")_".03;"_$SELECT('UCK:".04///^S X=TODAY-1",1:".04")_";.05//^S X=$E(""0000"",1,4-$L(ID))_ID;"_$SELECT(PCK<1:".06///0",1:".06")
+9 ;If this is a newly added user, we don't need double alerts.
+10 IF 'ADDFLG
Begin DoDot:1
+11 if PCK<1
WRITE !,"No Valid/Active PERSON CLASS, STATUS forced to STUDENT"
+12 if 'UCK
WRITE !," No Valid USR CLASS, User forced INACTIVE."
+13 QUIT
End DoDot:1
+14 DO ^DIE
+15 GOTO SRCH
+16 QUIT
+17 ;
NMVD ;Validate that the NEW PERSON names match the A&SP Staff names,
+1 ;If the NEW PERSON name was changed, The A&SP Name will be changed to match
+2 NEW NPIEN,NPNM,I,DIK
+3 SET I=0
SET DIK="^ACK(509850.3,"
SET DIK(1)=".01^B"
FOR
SET I=$ORDER(^ACK(509850.3,I))
if 'I
QUIT
Begin DoDot:1
+4 SET NPIEN=$PIECE(^ACK(509850.3,I,1),"^")
SET NPNM=$$GET1^DIQ(200,NPIEN,.01,"")
+5 IF $PIECE(^ACK(509850.3,I,0),"^")=NPNM
QUIT
+6 KILL ^ACK(509850.3,"B",$PIECE(^ACK(509850.3,I,0),"^"),I)
+7 SET $PIECE(^ACK(509850.3,I,0),"^")=NPNM
SET DA=I
+8 DO EN1^DIK
End DoDot:1
+9 QUIT
+10 ;
PCCHK(NPIEN) ;Check if User has a PERSON CLASS valid to QUASAR.
+1 ; Input:
+2 ; NPIEN = New Person File IEN
+3 ; Output:
+4 ; 1 - if Audiology/Valid Quasra person class exists and is active
+5 ; 0 - No valid Quasar person class exists or is active(can be student)
+6 ; -1 - No Person classes assigned to this user(can be student)
+7 ;
+8 NEW I,EFDT,EXPDT,X,RETRN,TODAY,PCLS
+9 SET RETRN=0
SET PCLS=""
+10 DO NOW^%DTC
SET TODAY=$PIECE(%,".")
+11 FOR I=1:1
KILL ACKQARY
DO GETS^DIQ(200.05,I_","_NPIEN,".01;2:3","I","ACKQARY")
if '$DATA(ACKQARY)
QUIT
Begin DoDot:1
+12 ;Unimplemented checks (Possible future use?)
+13 ;S PCLS=$$GET1^DIQ(8932.1,$G(ACKQARY(200.05,I_","_NPIEN_",",.01,"I")),5,"") Q:(I=1)&(PCLS="")
+14 ;I '((PCLS["V140200")!(PCLS["V140701")!(PCLS["V140600")!(PCLS["V140500")) Q
+15 SET EFDT=$GET(ACKQARY(200.05,I_","_NPIEN_",",2,"I"))
SET EXPDT=$GET(ACKQARY(200.05,I_","_NPIEN_",",3,"I"))
+16 IF (EFDT<=TODAY)
IF (+EXPDT=0)!(EXPDT>TODAY)
SET RETRN=1
End DoDot:1
+17 KILL ACKQARY
+18 IF I=1
IF PCLS=""
QUIT -1
+19 QUIT RETRN
+20 ;
USRCHK(NPNM) ;Check if User has valid USR Class
+1 ; Input:
+2 ; NPNM = FILE 200 NAME
+3 ; Output:
+4 ; Returns 1 if Valid, 0 if invalid.
+5 ;
+6 NEW USRARY,I,RETRN,TODAY,USRIEN
+7 DO NOW^%DTC
SET RETRN=0
SET TODAY=$PIECE(%,".")
+8 KILL USRARY
DO FIND^DIC(8930.3,"",".01","",NPNM,"","B","","","USRARY")
+9 SET I=0
FOR
SET I=$ORDER(USRARY("DILIST",2,I))
if 'I!RETRN
QUIT
Begin DoDot:1
+10 SET RETRN=1
SET USRIEN=USRARY("DILIST",2,I)
+11 IF +$$GET1^DIQ(8930.3,USRIEN,".03","I")>TODAY
SET RETRN=0
+12 IF +$$GET1^DIQ(8930.3,USRIEN,".04","I")<=TODAY
IF +$$GET1^DIQ(8930.3,USRIEN,".04","I")>0
SET RETRN=0
End DoDot:1
+13 QUIT RETRN
+14 ;
EX KILL DIC,DIK,DIE,DR,X,Y,RSLT,ACKIEN,USRARY,ACKQARY,TODAY,RETRN,ID
+1 QUIT
