QAOSENTR ;HISC/JES,DAD-ENTER EDIT AN OCCURRENCE ;6/24/93 15:41
;;3.0;Occurrence Screen;;09/14/1993
S HELPYN="W !?5,""Please answer Y(es) or N(o)"""
ASK ;
W !!?5,"Do you wish to see list of open occurrences"
S %=2,DTOUT=0 D YN^DICN D:%=1 ENLOOK G:%=-1 EXIT I %=0 X HELPYN G ASK
ENTER ;
W ! K DIC S DIC="^DPT(",DIC(0)="AEMQ",DIC("A")="Select PATIENT: "
D ^DIC G:Y=-1 EXIT S QANAME=+Y
DATE ;
K %DT S %DT="AETX",%DT(0)="-NOW",%DT("A")="Select OCCURRENCE DATE: "
D ^%DT K %DT G:Y=-1 NOTHERE S QADATE=+Y
DAGAIN ;
W !!?5,"Is this the correct date (Y/N)" S %=1,DTOUT=0
D YN^DICN G:%=2 DATE G:%=-1 EXIT I %=0 X HELPYN G DAGAIN
W ! K DIC S DIC="^QA(741.1,",DIC(0)="AEMQ",DIC("A")="Select SCREEN: "
S DIC("S")="I $P(^(0),""^"",4)'=1"
D ^DIC K DIC W ! G:Y=-1 NOTHERE S QASCRN=+Y
D ^QAOSENT1 I QAOSQUIT S QAOSQUIT=0 G ENTER
S QADEAD=0,QADDEAD="" D ISHEDEAD
I QADDEAD]"" W *7,!!?5,"You cannot enter an occurrence for this patient, who died on ",QADDEAD,".",! G ENTER
I QADEAD,+^QA(741.1,QASCRN,0)=109 W *7,!!?5,"You cannot enter more than one death for the same patient.",! G ENTER
K VAIP S DFN=QANAME,VAIP("D")=QADATE\1,VAIP("M")=0 D IN5^VADPT
K DD,DIC,DINUM,DO S DIC="^QA(741,",DIC(0)="L",DLAYGO=741,X=QANAME
D FILE^DICN K DIC S (DA,QAOSD0)=+Y
G:QAOSD0'>0 ENTER
S DR="1///^S X=QADATE;3///`"_QASCRN_";28///^S X=DT"
I $D(^DGPM(+VAIP(1),0))#2,QADATE\1'<(VAIP(3)\1) S DR=DR_";.02///`"_+VAIP(1)
S DIE="^QA(741,",DR=DR_";4",DA=QAOSD0 D ^DIE S SAVEY=$D(Y)
S QAUDIT("FILE")="741^27",QAUDIT("DA")=QAOSD0,QAUDIT("ACTION")="o"
S QAUDIT("COMMENT")="OPEN A RECORD"
D ^QAQAUDIT G:SAVEY ENTER K DR G:($D(DTOUT))!($D(DUOUT)) NOTHERE
G ASKEDIT
NOTHERE ;
W !!?5,"This occurrence has not yet been entered into the system"
W !?5,"Do you wish to go back to the enter step (Y/N)",*7
S %=1,DTOUT=0 D YN^DICN G:%=1 ENTER G:%=-1 EXIT I %=0 X HELPYN G NOTHERE
G EXIT
ISHEDEAD ;
S QAOS109=$O(^QA(741.1,"B",109,0)) Q:QAOS109'>0
F QAWHEN=0:0 S QAWHEN=$O(^QA(741,"AA",QAOS109,QAWHEN)) Q:QAWHEN'>0 S QAPAT=0 D WHODEAD
Q
WHODEAD ;
S QAPAT=$O(^QA(741,"AA",QAOS109,QAWHEN,QANAME,QAPAT)) Q:QAPAT'>0
I $P(^QA(741,QAPAT,0),"^",11)'=2 S QADEAD=QADEAD+1 I QAWHEN\1<(QADATE\1) S SAVEY=Y,Y=QAWHEN\1 X ^DD("DD") S QADDEAD=Y,Y=SAVEY
G WHODEAD
ASKEDIT ;
W !!?5,"Do you wish to make any corrections to this entry (Y/N)",*7
S %=2,DTOUT=0 D YN^DICN G:%=2 ASKREVU G:%=1 EDIT G:X=-1 EXIT
I %=0 X HELPYN G ASKEDIT
EDIT ;
W ! S DIE="^QA(741,",DR="1;3;4" D ^DIE
ASKREVU ;
W *7,!!?5,"Do you wish to start review process for this entry (Y/N)"
S %=1,DTOUT=0 D YN^DICN G:%=2 ENTER G:X=-1 EXIT I %=0 X HELPYN G ASKREVU
REVIEW ;
D EN1^QAOEDT0 G ENTER
Q
EXIT ;
K ACTIVE,DA,DIC,DIE,DR,DTOUT,DUOUT,DZ,HELPYN,I,III,IV,LINE21,LOC,PRINTEE
K QAUDIT,QADAT,QADATE,QADEAD,QADDEAD,QAJUL,QANAM,QANAME,QAOS109,QAOSAUDT
K QAOSOPEN,QAPAT,QASCREEN,QASCRN,QASTOP,QAOSWHAT,QAWHEN,QAWHO,SAVEY
K SAVY,V,X,Y,%,%DT,%T,C,D0,D1,D2,DI,DIG,DIH,DIPGM,DIU,DIV,DK,DL,QA
K QAHOLD,QAI,QALINE,QAOSLOC,QACLOSE,QAOSWRD,SAVEX,Y,Z,QAOS,QAOSD0,QAOSD1
K QAOSDATA,QAOSFDSP,QAOSFIND,QAOSFOND,QAOSLEVL,QAOSLVNO,QAOSMGMT
K QAOSNEWF,QAOSQUIT,QAOSX,QAOSREVR,QAOFIELD,QAOSNODE,QAOSSERV,QAOSUBDD
K ^TMP($J,"L")
D KVAR^VADPT
Q
ENLOOK ;
W ! D WAIT^DICD W ! K ^TMP($J,"L") S LINE21=$Y,QASTOP=0
F QAWHO=0:0 S QAWHO=$O(^QA(741,"AD",0,QAWHO)) Q:QAWHO'>0 D
. S LOC=$G(^QA(741,QAWHO,0))
. Q:LOC'>0 Q:'$D(^DPT(+LOC,0))
. S QANAM=$P(^DPT(+LOC,0),"^"),QAJUL=$P(LOC,"^",3)
. S QASCREEN=$S($D(^QA(741.1,+$G(^QA(741,QAWHO,"SCRN")),0))#2:$P(^(0),"^"),1:+^QA(741,QAWHO,"SCRN"))
. S:$D(Y) SAVY=Y S Y=QAJUL X ^DD("DD") S QADAT=Y S:$D(SAVY) Y=SAVY
. S ^TMP($J,"L",QANAM,QAJUL,QASCREEN)=QANAM_"^"_QADAT_"^"_QASCREEN
. Q
I $O(^TMP($J,"L",""))="" W !?5,"*** NO OPEN OCCURRENCES FOUND ***" Q
S QANAM=""
F S QANAM=$O(^TMP($J,"L",QANAM)) Q:QANAM=""!(QASTOP="^") F QAJUL=0:0 S QAJUL=$O(^TMP($J,"L",QANAM,QAJUL)) Q:QAJUL=""!(QASTOP="^") F QASCREEN=0:0 S QASCREEN=$O(^TMP($J,"L",QANAM,QAJUL,QASCREEN)) Q:QASCREEN=""!(QASTOP="^") D
. S PRINTEE=^TMP($J,"L",QANAM,QAJUL,QASCREEN)
. W !?5,$P(PRINTEE,"^",1),?30,$P(PRINTEE,"^",2),?50,$P(PRINTEE,"^",3)
. I $Y>(IOSL+LINE21-3) K DIR S DIR(0)="E" D ^DIR K DIR S QASTOP=$S(Y'>0:"^",1:0) S LINE21=$Y
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSENTR 4270 printed Sep 23, 2025@19:57:45 Page 2
QAOSENTR ;HISC/JES,DAD-ENTER EDIT AN OCCURRENCE ;6/24/93 15:41
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 SET HELPYN="W !?5,""Please answer Y(es) or N(o)"""
ASK ;
+1 WRITE !!?5,"Do you wish to see list of open occurrences"
+2 SET %=2
SET DTOUT=0
DO YN^DICN
if %=1
DO ENLOOK
if %=-1
GOTO EXIT
IF %=0
XECUTE HELPYN
GOTO ASK
ENTER ;
+1 WRITE !
KILL DIC
SET DIC="^DPT("
SET DIC(0)="AEMQ"
SET DIC("A")="Select PATIENT: "
+2 DO ^DIC
if Y=-1
GOTO EXIT
SET QANAME=+Y
DATE ;
+1 KILL %DT
SET %DT="AETX"
SET %DT(0)="-NOW"
SET %DT("A")="Select OCCURRENCE DATE: "
+2 DO ^%DT
KILL %DT
if Y=-1
GOTO NOTHERE
SET QADATE=+Y
DAGAIN ;
+1 WRITE !!?5,"Is this the correct date (Y/N)"
SET %=1
SET DTOUT=0
+2 DO YN^DICN
if %=2
GOTO DATE
if %=-1
GOTO EXIT
IF %=0
XECUTE HELPYN
GOTO DAGAIN
+3 WRITE !
KILL DIC
SET DIC="^QA(741.1,"
SET DIC(0)="AEMQ"
SET DIC("A")="Select SCREEN: "
+4 SET DIC("S")="I $P(^(0),""^"",4)'=1"
+5 DO ^DIC
KILL DIC
WRITE !
if Y=-1
GOTO NOTHERE
SET QASCRN=+Y
+6 DO ^QAOSENT1
IF QAOSQUIT
SET QAOSQUIT=0
GOTO ENTER
+7 SET QADEAD=0
SET QADDEAD=""
DO ISHEDEAD
+8 IF QADDEAD]""
WRITE *7,!!?5,"You cannot enter an occurrence for this patient, who died on ",QADDEAD,".",!
GOTO ENTER
+9 IF QADEAD
IF +^QA(741.1,QASCRN,0)=109
WRITE *7,!!?5,"You cannot enter more than one death for the same patient.",!
GOTO ENTER
+10 KILL VAIP
SET DFN=QANAME
SET VAIP("D")=QADATE\1
SET VAIP("M")=0
DO IN5^VADPT
+11 KILL DD,DIC,DINUM,DO
SET DIC="^QA(741,"
SET DIC(0)="L"
SET DLAYGO=741
SET X=QANAME
+12 DO FILE^DICN
KILL DIC
SET (DA,QAOSD0)=+Y
+13 if QAOSD0'>0
GOTO ENTER
+14 SET DR="1///^S X=QADATE;3///`"_QASCRN_";28///^S X=DT"
+15 IF $DATA(^DGPM(+VAIP(1),0))#2
IF QADATE\1'<(VAIP(3)\1)
SET DR=DR_";.02///`"_+VAIP(1)
+16 SET DIE="^QA(741,"
SET DR=DR_";4"
SET DA=QAOSD0
DO ^DIE
SET SAVEY=$DATA(Y)
+17 SET QAUDIT("FILE")="741^27"
SET QAUDIT("DA")=QAOSD0
SET QAUDIT("ACTION")="o"
+18 SET QAUDIT("COMMENT")="OPEN A RECORD"
+19 DO ^QAQAUDIT
if SAVEY
GOTO ENTER
KILL DR
if ($DATA(DTOUT))!($DATA(DUOUT))
GOTO NOTHERE
+20 GOTO ASKEDIT
NOTHERE ;
+1 WRITE !!?5,"This occurrence has not yet been entered into the system"
+2 WRITE !?5,"Do you wish to go back to the enter step (Y/N)",*7
+3 SET %=1
SET DTOUT=0
DO YN^DICN
if %=1
GOTO ENTER
if %=-1
GOTO EXIT
IF %=0
XECUTE HELPYN
GOTO NOTHERE
+4 GOTO EXIT
ISHEDEAD ;
+1 SET QAOS109=$ORDER(^QA(741.1,"B",109,0))
if QAOS109'>0
QUIT
+2 FOR QAWHEN=0:0
SET QAWHEN=$ORDER(^QA(741,"AA",QAOS109,QAWHEN))
if QAWHEN'>0
QUIT
SET QAPAT=0
DO WHODEAD
+3 QUIT
WHODEAD ;
+1 SET QAPAT=$ORDER(^QA(741,"AA",QAOS109,QAWHEN,QANAME,QAPAT))
if QAPAT'>0
QUIT
+2 IF $PIECE(^QA(741,QAPAT,0),"^",11)'=2
SET QADEAD=QADEAD+1
IF QAWHEN\1<(QADATE\1)
SET SAVEY=Y
SET Y=QAWHEN\1
XECUTE ^DD("DD")
SET QADDEAD=Y
SET Y=SAVEY
+3 GOTO WHODEAD
ASKEDIT ;
+1 WRITE !!?5,"Do you wish to make any corrections to this entry (Y/N)",*7
+2 SET %=2
SET DTOUT=0
DO YN^DICN
if %=2
GOTO ASKREVU
if %=1
GOTO EDIT
if X=-1
GOTO EXIT
+3 IF %=0
XECUTE HELPYN
GOTO ASKEDIT
EDIT ;
+1 WRITE !
SET DIE="^QA(741,"
SET DR="1;3;4"
DO ^DIE
ASKREVU ;
+1 WRITE *7,!!?5,"Do you wish to start review process for this entry (Y/N)"
+2 SET %=1
SET DTOUT=0
DO YN^DICN
if %=2
GOTO ENTER
if X=-1
GOTO EXIT
IF %=0
XECUTE HELPYN
GOTO ASKREVU
REVIEW ;
+1 DO EN1^QAOEDT0
GOTO ENTER
+2 QUIT
EXIT ;
+1 KILL ACTIVE,DA,DIC,DIE,DR,DTOUT,DUOUT,DZ,HELPYN,I,III,IV,LINE21,LOC,PRINTEE
+2 KILL QAUDIT,QADAT,QADATE,QADEAD,QADDEAD,QAJUL,QANAM,QANAME,QAOS109,QAOSAUDT
+3 KILL QAOSOPEN,QAPAT,QASCREEN,QASCRN,QASTOP,QAOSWHAT,QAWHEN,QAWHO,SAVEY
+4 KILL SAVY,V,X,Y,%,%DT,%T,C,D0,D1,D2,DI,DIG,DIH,DIPGM,DIU,DIV,DK,DL,QA
+5 KILL QAHOLD,QAI,QALINE,QAOSLOC,QACLOSE,QAOSWRD,SAVEX,Y,Z,QAOS,QAOSD0,QAOSD1
+6 KILL QAOSDATA,QAOSFDSP,QAOSFIND,QAOSFOND,QAOSLEVL,QAOSLVNO,QAOSMGMT
+7 KILL QAOSNEWF,QAOSQUIT,QAOSX,QAOSREVR,QAOFIELD,QAOSNODE,QAOSSERV,QAOSUBDD
+8 KILL ^TMP($JOB,"L")
+9 DO KVAR^VADPT
+10 QUIT
ENLOOK ;
+1 WRITE !
DO WAIT^DICD
WRITE !
KILL ^TMP($JOB,"L")
SET LINE21=$Y
SET QASTOP=0
+2 FOR QAWHO=0:0
SET QAWHO=$ORDER(^QA(741,"AD",0,QAWHO))
if QAWHO'>0
QUIT
Begin DoDot:1
+3 SET LOC=$GET(^QA(741,QAWHO,0))
+4 if LOC'>0
QUIT
if '$DATA(^DPT(+LOC,0))
QUIT
+5 SET QANAM=$PIECE(^DPT(+LOC,0),"^")
SET QAJUL=$PIECE(LOC,"^",3)
+6 SET QASCREEN=$SELECT($DATA(^QA(741.1,+$GET(^QA(741,QAWHO,"SCRN")),0))#2:$PIECE(^(0),"^"),1:+^QA(741,QAWHO,"SCRN"))
+7 if $DATA(Y)
SET SAVY=Y
SET Y=QAJUL
XECUTE ^DD("DD")
SET QADAT=Y
if $DATA(SAVY)
SET Y=SAVY
+8 SET ^TMP($JOB,"L",QANAM,QAJUL,QASCREEN)=QANAM_"^"_QADAT_"^"_QASCREEN
+9 QUIT
End DoDot:1
+10 IF $ORDER(^TMP($JOB,"L",""))=""
WRITE !?5,"*** NO OPEN OCCURRENCES FOUND ***"
QUIT
+11 SET QANAM=""
+12 FOR
SET QANAM=$ORDER(^TMP($JOB,"L",QANAM))
if QANAM=""!(QASTOP="^")
QUIT
FOR QAJUL=0:0
SET QAJUL=$ORDER(^TMP($JOB,"L",QANAM,QAJUL))
if QAJUL=""!(QASTOP="^")
QUIT
FOR QASCREEN=0:0
SET QASCREEN=$ORDER(^TMP($JOB,"L",QANAM,QAJUL,QASCREEN))
if QASCREEN=""!(QASTOP="^")
QUIT
Begin DoDot:1
+13 SET PRINTEE=^TMP($JOB,"L",QANAM,QAJUL,QASCREEN)
+14 WRITE !?5,$PIECE(PRINTEE,"^",1),?30,$PIECE(PRINTEE,"^",2),?50,$PIECE(PRINTEE,"^",3)
+15 IF $Y>(IOSL+LINE21-3)
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET QASTOP=$SELECT(Y'>0:"^",1:0)
SET LINE21=$Y
+16 QUIT
End DoDot:1
+17 QUIT
