- 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 Jan 18, 2025@03:33:11 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