- 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 Feb 18, 2025@23:47:55 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
