source: WorldVistAEHR/trunk/r/OCCURRENCE_SCREEN-QAO/QAOSENTR.m@ 634

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