QAMEDT5A ;HISC/DAD-EDIT MANUALLY ENROLL A FALL OUT ;12/14/92 09:05
;;1.0;Clinical Monitoring System;;09/13/1993
S QAUDIT("ACTION")="e",QAUDIT("COMMENT")="MANUAL EDIT OF FALL OUT DATA" D AUDIT S DIE="^QA(743.1,",DR=".01;.02;.03",DA=QAMREC W ! D ^DIE G:($D(DA)[0)!$D(Y) EXIT
S QAMQUIT=0 F QAMD1=0:0 S QAMD1=$O(^QA(743,QAMD0,"DAT",QAMD1)) Q:QAMD1'>0!QAMQUIT D LOOP1
EXIT ;
Q
LOOP1 ; *** LOOP THRU DATA ELEMENTS
K DIR,DIRUT S QAMFLD=+^QA(743,QAMD0,"DAT",QAMD1,0)
S QAMIEN=$O(^QA(743.1,QAMREC,1,"B",QAMFLD,0))
I QAMIEN'>0 S:$D(^QA(743.1,QAMREC,1,0))[0 ^QA(743.1,QAMREC,1,0)="^743.11PA^^" K DD,DIC,DINUM,DO S DIC="^QA(743.1,"_QAMREC_",1,",DIC(0)="LM",DLAYGO=743.1,(DA(1),D0)=QAMREC,X=QAMFLD D FILE^DICN S QAMIEN=+Y
S QAMELEM=QAMFLD D EN1^QAMUTL2 Q:$D(DIR(0))[0 Q:$D(DIR("A"))[0
S QAMDIR("B")=$S($D(^QA(743.1,QAMREC,1,QAMIEN,"E"))#2:^("E"),1:"")
I QAMDIR("B")="" K QAMELEM S QAMELEM=+^QA(743,QAMD0,"DAT",QAMD1,0),QAM=$S($D(^QA(743.1,QAMREC,0))#2:^(0),1:""),QAMDFN=+QAM,QAMEVENT=$P(QAM,"^",3) D DEFAULT S QAMDIR("B")=X
S DIR("B")=$S(QAMDIR("B")]"":QAMDIR("B"),$D(DIR("B"))#2:DIR("B"),1:"") K:DIR("B")="" DIR("B")
I $E(DIR(0))="P",'$$EXIST^QAMUTL1(+$P(DIR(0),"^",2)) D G DIRCHK
. W !,$P($G(^QA(743.4,QAMFLD,0)),"^"),":"
. W !!?5,"*** File not found !! ***",*7,!
. S X="",DIRUT=1 K DTOUT,QADIROUT
. Q
DIR D ^DIR S:(Y'>0)&($P(DIR(0),"^")["P") DIRUT=1
DIRCHK I $D(DIRUT),'$D(DTOUT) S Y="" K:X="" DIRUT G DONE:($E(X)="^")!(X=""),DIR:(X]"")&(X'="@") I X="@" D DELETE K:QAMPCENT=1 DIRUT G:QAMPCENT=2 DIR Q:QAMPCENT=1
DONE I $D(DIRUT) S QAMQUIT=1 Q
I $D(QADIROUT)#2,QADIROUT]"" X QADIROUT
I Y]"" K DIC,DIE,DIR,DR S DIE="^QA(743.1,"_QAMREC_",1,",(D0,DA(1))=QAMREC,(D1,DA)=QAMIEN,DR=".02///"_Y D ^DIE
Q
DELETE ; *** DELETE DATA FOR DATA ELEMENT
N DIC,DIR
DEL S (QAMPCENT,%)=2 I $S($D(^QA(743.1,QAMREC,1,QAMIEN,"E"))[0:1,^("E")="":1,1:0) W " ??",*7 Q
W !?5,*7,"SURE YOU WANT TO DELETE" D YN^DICN S QAMPCENT=% W " ",$S(%=1:"<DELETED>",%=2:"<NOTHING DELETED>",1:"") I '% W !!?10,"Please answer Y(es) or N(o)",! G DEL
I %=1 K DIE,DR S DIE="^QA(743.1,"_QAMREC_",1,",(D0,DA(1))=QAMREC,(D1,DA)=QAMIEN,DR=".02///@" D ^DIE
Q
DEFAULT ; *** COMPUTE DEFAULT VALUE FOR DATA ELEMENT
; *** REQUIRES: QAMDFN, QAMELEM, QAMEVENT
K DA,DIC,DIQ,DR,QAMDTPT
S DIQ="QAMELEM",DIQ(0)="E",DIC=$S($D(^QA(743.4,QAMELEM,0))#2:$P(^(0),"^",3),1:0) G:DIC'>0 FIN
I $D(QADIRPNT)#2,QADIRPNT]"" X QADIRPNT ; S QAMDTPT(1,2,3,...,n) = D0,D1,D2,...,Dn
G:'$D(QAMDTPT) FIN S (MAX,QAMDD("MAX"),QAMDA("MAX"),QAMFIELD("MAX"))=0
F QAME1=0:0 S QAME1=$O(^QA(743.4,QAMELEM,"DD",QAME1)) Q:QAME1'>0 S X=^QA(743.4,QAMELEM,"DD",QAME1,0),QAMDD=+X,QAMFIELD=+$P(X,"^",2),QAMLEVL=+$P(X,"^",3) D LOOP2
D EN^DIQ1 ; *** S QAMELEM(file#,DA,field#,"E") = EXTERNAL DATA FORMAT
FIN ;
S X=$S($D(QAMELEM(QAMDD("MAX"),QAMDA("MAX"),QAMFIELD("MAX"),"E"))#2:QAMELEM(QAMDD("MAX"),QAMDA("MAX"),QAMFIELD("MAX"),"E"),1:"")
Q
LOOP2 ;
I QAMLEVL=1 S (DA,QADA)=$S($D(QAMDTPT(QAMLEVL))#2:QAMDTPT(QAMLEVL),1:0),DR=QAMFIELD
E S (DA(QAMDD),QADA)=$S($D(QAMDTPT(QAMLEVL))#2:QAMDTPT(QAMLEVL),1:0),DR(QAMDD)=QAMFIELD
I QAMLEVL>MAX S QAMFIELD("MAX")=QAMFIELD,QAMDA("MAX")=QADA,QAMDD("MAX")=QAMDD,MAX=QAMLEVL
Q
AUDIT ;GENERATE THE AUDIT RECORD FOR THIS EDIT
S QAUDIT("FILE")="743.1^100",QAUDIT("DA")=QAMREC D ^QAQAUDIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAMEDT5A 3311 printed Dec 13, 2024@01:42:23 Page 2
QAMEDT5A ;HISC/DAD-EDIT MANUALLY ENROLL A FALL OUT ;12/14/92 09:05
+1 ;;1.0;Clinical Monitoring System;;09/13/1993
+2 SET QAUDIT("ACTION")="e"
SET QAUDIT("COMMENT")="MANUAL EDIT OF FALL OUT DATA"
DO AUDIT
SET DIE="^QA(743.1,"
SET DR=".01;.02;.03"
SET DA=QAMREC
WRITE !
DO ^DIE
if ($DATA(DA)[0)!$DATA(Y)
GOTO EXIT
+3 SET QAMQUIT=0
FOR QAMD1=0:0
SET QAMD1=$ORDER(^QA(743,QAMD0,"DAT",QAMD1))
if QAMD1'>0!QAMQUIT
QUIT
DO LOOP1
EXIT ;
+1 QUIT
LOOP1 ; *** LOOP THRU DATA ELEMENTS
+1 KILL DIR,DIRUT
SET QAMFLD=+^QA(743,QAMD0,"DAT",QAMD1,0)
+2 SET QAMIEN=$ORDER(^QA(743.1,QAMREC,1,"B",QAMFLD,0))
+3 IF QAMIEN'>0
if $DATA(^QA(743.1,QAMREC,1,0))[0
SET ^QA(743.1,QAMREC,1,0)="^743.11PA^^"
KILL DD,DIC,DINUM,DO
SET DIC="^QA(743.1,"_QAMREC_",1,"
SET DIC(0)="LM"
SET DLAYGO=743.1
SET (DA(1),D0)=QAMREC
SET X=QAMFLD
DO FILE^DICN
SET QAMIEN=+Y
+4 SET QAMELEM=QAMFLD
DO EN1^QAMUTL2
if $DATA(DIR(0))[0
QUIT
if $DATA(DIR("A"))[0
QUIT
+5 SET QAMDIR("B")=$SELECT($DATA(^QA(743.1,QAMREC,1,QAMIEN,"E"))#2:^("E"),1:"")
+6 IF QAMDIR("B")=""
KILL QAMELEM
SET QAMELEM=+^QA(743,QAMD0,"DAT",QAMD1,0)
SET QAM=$SELECT($DATA(^QA(743.1,QAMREC,0))#2:^(0),1:"")
SET QAMDFN=+QAM
SET QAMEVENT=$PIECE(QAM,"^",3)
DO DEFAULT
SET QAMDIR("B")=X
+7 SET DIR("B")=$SELECT(QAMDIR("B")]"":QAMDIR("B"),$DATA(DIR("B"))#2:DIR("B"),1:"")
if DIR("B")=""
KILL DIR("B")
+8 IF $EXTRACT(DIR(0))="P"
IF '$$EXIST^QAMUTL1(+$PIECE(DIR(0),"^",2))
Begin DoDot:1
+9 WRITE !,$PIECE($GET(^QA(743.4,QAMFLD,0)),"^"),":"
+10 WRITE !!?5,"*** File not found !! ***",*7,!
+11 SET X=""
SET DIRUT=1
KILL DTOUT,QADIROUT
+12 QUIT
End DoDot:1
GOTO DIRCHK
DIR DO ^DIR
if (Y'>0)&($PIECE(DIR(0),"^")["P")
SET DIRUT=1
DIRCHK IF $DATA(DIRUT)
IF '$DATA(DTOUT)
SET Y=""
if X=""
KILL DIRUT
if ($EXTRACT(X)="^")!(X="")
GOTO DONE
if (X]"")&(X'="@")
GOTO DIR
IF X="@"
DO DELETE
if QAMPCENT=1
KILL DIRUT
if QAMPCENT=2
GOTO DIR
if QAMPCENT=1
QUIT
DONE IF $DATA(DIRUT)
SET QAMQUIT=1
QUIT
+1 IF $DATA(QADIROUT)#2
IF QADIROUT]""
XECUTE QADIROUT
+2 IF Y]""
KILL DIC,DIE,DIR,DR
SET DIE="^QA(743.1,"_QAMREC_",1,"
SET (D0,DA(1))=QAMREC
SET (D1,DA)=QAMIEN
SET DR=".02///"_Y
DO ^DIE
+3 QUIT
DELETE ; *** DELETE DATA FOR DATA ELEMENT
+1 NEW DIC,DIR
DEL SET (QAMPCENT,%)=2
IF $SELECT($DATA(^QA(743.1,QAMREC,1,QAMIEN,"E"))[0:1,^("E")="":1,1:0)
WRITE " ??",*7
QUIT
+1 WRITE !?5,*7,"SURE YOU WANT TO DELETE"
DO YN^DICN
SET QAMPCENT=%
WRITE " ",$SELECT(%=1:"<DELETED>",%=2:"<NOTHING DELETED>",1:"")
IF '%
WRITE !!?10,"Please answer Y(es) or N(o)",!
GOTO DEL
+2 IF %=1
KILL DIE,DR
SET DIE="^QA(743.1,"_QAMREC_",1,"
SET (D0,DA(1))=QAMREC
SET (D1,DA)=QAMIEN
SET DR=".02///@"
DO ^DIE
+3 QUIT
DEFAULT ; *** COMPUTE DEFAULT VALUE FOR DATA ELEMENT
+1 ; *** REQUIRES: QAMDFN, QAMELEM, QAMEVENT
+2 KILL DA,DIC,DIQ,DR,QAMDTPT
+3 SET DIQ="QAMELEM"
SET DIQ(0)="E"
SET DIC=$SELECT($DATA(^QA(743.4,QAMELEM,0))#2:$PIECE(^(0),"^",3),1:0)
if DIC'>0
GOTO FIN
+4 ; S QAMDTPT(1,2,3,...,n) = D0,D1,D2,...,Dn
IF $DATA(QADIRPNT)#2
IF QADIRPNT]""
XECUTE QADIRPNT
+5 if '$DATA(QAMDTPT)
GOTO FIN
SET (MAX,QAMDD("MAX"),QAMDA("MAX"),QAMFIELD("MAX"))=0
+6 FOR QAME1=0:0
SET QAME1=$ORDER(^QA(743.4,QAMELEM,"DD",QAME1))
if QAME1'>0
QUIT
SET X=^QA(743.4,QAMELEM,"DD",QAME1,0)
SET QAMDD=+X
SET QAMFIELD=+$PIECE(X,"^",2)
SET QAMLEVL=+$PIECE(X,"^",3)
DO LOOP2
+7 ; *** S QAMELEM(file#,DA,field#,"E") = EXTERNAL DATA FORMAT
DO EN^DIQ1
FIN ;
+1 SET X=$SELECT($DATA(QAMELEM(QAMDD("MAX"),QAMDA("MAX"),QAMFIELD("MAX"),"E"))#2:QAMELEM(QAMDD("MAX"),QAMDA("MAX"),QAMFIELD("MAX"),"E"),1:"")
+2 QUIT
LOOP2 ;
+1 IF QAMLEVL=1
SET (DA,QADA)=$SELECT($DATA(QAMDTPT(QAMLEVL))#2:QAMDTPT(QAMLEVL),1:0)
SET DR=QAMFIELD
+2 IF '$TEST
SET (DA(QAMDD),QADA)=$SELECT($DATA(QAMDTPT(QAMLEVL))#2:QAMDTPT(QAMLEVL),1:0)
SET DR(QAMDD)=QAMFIELD
+3 IF QAMLEVL>MAX
SET QAMFIELD("MAX")=QAMFIELD
SET QAMDA("MAX")=QADA
SET QAMDD("MAX")=QAMDD
SET MAX=QAMLEVL
+4 QUIT
AUDIT ;GENERATE THE AUDIT RECORD FOR THIS EDIT
+1 SET QAUDIT("FILE")="743.1^100"
SET QAUDIT("DA")=QAMREC
DO ^QAQAUDIT
+2 QUIT
