QACSTAT ;HISC/RS - This routine will reopen, close, or delete a contact for the Patient Rep. ;3/21/95 10:03
;;2.0;Patient Representative;**3,5**;07/25/1995
S (DIC,DIE)="^QA(745.1,",DIC(0)="AEMQZ",DIC("A")="Select CONTACT NUMBER: "
D ^DIC I Y<0!(Y="^") K DIC,DIE Q
;Display Contact data to be reopen or deleted
K DA,DR,DIC,DIQ,TMP
S DA=+Y,DIC=745.1,DIQ="TMP",DR=".01;1;2;3;4;5;6;7" D EN^DIQ1
W @IOF,!!,?10,"This option will allow the user to open, close, or delete",!,?15,"a Patient Representative Contact record",!
S N1="" F S N1=$O(TMP(745.1,N1)) Q:N1="" S N2="" F S N2=$O(TMP(745.1,N1,N2)) Q:N2="" S QACDATA=TMP(745.1,N1,N2) D
.Q:QACDATA=""
.S FLD=N2*100\1,TEXT=$P($T(@FLD),";;",2),TAB=$P(TEXT,"^"),LINE=$P(TEXT,"^",2),CODE=$P(TEXT,"^",3,99)
.W:TAB=0 !
.W ?TAB,LINE
.X CODE
.Q
K TMP,DIQ,N1,N2,QACDATA,FLD,TAB,TEXT,LINE,CODE
;Ask what the user want to to with the record.
S DIR(0)="SMO^O:Open;C:Closed;D:Delete",DIR("A")="STATUS",QACALERT=1
S STAT=$P($G(^QA(745.1,DA,7)),"^",2),DIR("B")=$S(STAT="O":"Open",STAT="C":"Closed",1:"") D ^DIR G END:Y<0
S LINE=$S(Y="O":"OPEN",Y="C":"CLOSE",Y="D":"DELE",1:"END") D @LINE
G END
OPEN S DR="27///^S X=""O"";26///^S X=""@""" D ^DIE K DR Q
CLOSE S II=0 I $O(^QA(745.1,DA,3,II))']"" D
. W !!?5,"Reports of Contact cannot be resolved without Issue Code(s)."
. S QACIFLG=1
S II=0 F S II=$O(^QA(745.1,DA,3,II)) Q:II'>0 D
. S SS=0 I $O(^QA(745.1,DA,3,II,3,SS))']"" D
. . W !!?5,"Reports of Contact cannot be resolved without a Service/Discipline",!?5,"for each Issue Code."
. . S QACSFLG=1
I $G(QACIFLG)=1!($G(QACSFLG)=1) K QACIFLG,QACSFLG Q
S DR="26///TODAY" D ^DIE K DR Q
DELE N DIR W !,*7,*7 S DIR("A")="SURE YOU WANT TO DELETE THE ENTIRE *"_$P(^QA(745.1,DA,0),"^",1)_"* CONSUMER CONTACT"
S DIR(0)="Y" D ^DIR I Y'=1 W !,?30,"NOTHING DELETED" Q
S DIK=DIC D ^DIK Q
END K DIC,DIC,DIK,DIR,STAT,DR,DIE,DA,D0,DO,LINE,X,Y,%,%Y,D,DI,DQ,QACALERT
Q
TEXT ;This is for the display of data, tab,description,data info.
1 ;;0^Contact Number:^W ?21,QACDATA
100 ;;45^Date of Contact:^W ?63,QACDATA
200 ;;0^Patient Name:^W ?21,QACDATA
300 ;;45^Patient SSN (c):^W ?63,QACDATA
400 ;;0^Patient DOB (c):^S Y=QACDATA D DD^%DT S QACDATA=Y W ?21,QACDATA
500 ;;45^Patient sex (c):^W ?63,QACDATA
600 ;;0^Eligibility Status:^W ?21,QACDATA
700 ;;45^Patient Category:^W ?63,QACDATA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQACSTAT 2377 printed Jan 14, 2021@17:15:21 Page 2
QACSTAT ;HISC/RS - This routine will reopen, close, or delete a contact for the Patient Rep. ;3/21/95 10:03
+1 ;;2.0;Patient Representative;**3,5**;07/25/1995
+2 SET (DIC,DIE)="^QA(745.1,"
SET DIC(0)="AEMQZ"
SET DIC("A")="Select CONTACT NUMBER: "
+3 DO ^DIC
IF Y<0!(Y="^")
KILL DIC,DIE
QUIT
+4 ;Display Contact data to be reopen or deleted
+5 KILL DA,DR,DIC,DIQ,TMP
+6 SET DA=+Y
SET DIC=745.1
SET DIQ="TMP"
SET DR=".01;1;2;3;4;5;6;7"
DO EN^DIQ1
+7 WRITE @IOF,!!,?10,"This option will allow the user to open, close, or delete",!,?15,"a Patient Representative Contact record",!
+8 SET N1=""
FOR
SET N1=$ORDER(TMP(745.1,N1))
if N1=""
QUIT
SET N2=""
FOR
SET N2=$ORDER(TMP(745.1,N1,N2))
if N2=""
QUIT
SET QACDATA=TMP(745.1,N1,N2)
Begin DoDot:1
+9 if QACDATA=""
QUIT
+10 SET FLD=N2*100\1
SET TEXT=$PIECE($TEXT(@FLD),";;",2)
SET TAB=$PIECE(TEXT,"^")
SET LINE=$PIECE(TEXT,"^",2)
SET CODE=$PIECE(TEXT,"^",3,99)
+11 if TAB=0
WRITE !
+12 WRITE ?TAB,LINE
+13 XECUTE CODE
+14 QUIT
End DoDot:1
+15 KILL TMP,DIQ,N1,N2,QACDATA,FLD,TAB,TEXT,LINE,CODE
+16 ;Ask what the user want to to with the record.
+17 SET DIR(0)="SMO^O:Open;C:Closed;D:Delete"
SET DIR("A")="STATUS"
SET QACALERT=1
+18 SET STAT=$PIECE($GET(^QA(745.1,DA,7)),"^",2)
SET DIR("B")=$SELECT(STAT="O":"Open",STAT="C":"Closed",1:"")
DO ^DIR
if Y<0
GOTO END
+19 SET LINE=$SELECT(Y="O":"OPEN",Y="C":"CLOSE",Y="D":"DELE",1:"END")
DO @LINE
+20 GOTO END
OPEN SET DR="27///^S X=""O"";26///^S X=""@"""
DO ^DIE
KILL DR
QUIT
CLOSE SET II=0
IF $ORDER(^QA(745.1,DA,3,II))']""
Begin DoDot:1
+1 WRITE !!?5,"Reports of Contact cannot be resolved without Issue Code(s)."
+2 SET QACIFLG=1
End DoDot:1
+3 SET II=0
FOR
SET II=$ORDER(^QA(745.1,DA,3,II))
if II'>0
QUIT
Begin DoDot:1
+4 SET SS=0
IF $ORDER(^QA(745.1,DA,3,II,3,SS))']""
Begin DoDot:2
+5 WRITE !!?5,"Reports of Contact cannot be resolved without a Service/Discipline",!?5,"for each Issue Code."
+6 SET QACSFLG=1
End DoDot:2
End DoDot:1
+7 IF $GET(QACIFLG)=1!($GET(QACSFLG)=1)
KILL QACIFLG,QACSFLG
QUIT
+8 SET DR="26///TODAY"
DO ^DIE
KILL DR
QUIT
DELE NEW DIR
WRITE !,*7,*7
SET DIR("A")="SURE YOU WANT TO DELETE THE ENTIRE *"_$PIECE(^QA(745.1,DA,0),"^",1)_"* CONSUMER CONTACT"
+1 SET DIR(0)="Y"
DO ^DIR
IF Y'=1
WRITE !,?30,"NOTHING DELETED"
QUIT
+2 SET DIK=DIC
DO ^DIK
QUIT
END KILL DIC,DIC,DIK,DIR,STAT,DR,DIE,DA,D0,DO,LINE,X,Y,%,%Y,D,DI,DQ,QACALERT
+1 QUIT
TEXT ;This is for the display of data, tab,description,data info.
1 ;;0^Contact Number:^W ?21,QACDATA
100 ;;45^Date of Contact:^W ?63,QACDATA
200 ;;0^Patient Name:^W ?21,QACDATA
300 ;;45^Patient SSN (c):^W ?63,QACDATA
400 ;;0^Patient DOB (c):^S Y=QACDATA D DD^%DT S QACDATA=Y W ?21,QACDATA
500 ;;45^Patient sex (c):^W ?63,QACDATA
600 ;;0^Eligibility Status:^W ?21,QACDATA
700 ;;45^Patient Category:^W ?63,QACDATA
+1 QUIT
