QAOC1061 ;HISC/DAD-OCCURRENCE SCREEN AUTO ENROLLMENT ;5/13/93 09:05
;;3.0;Occurrence Screen;;09/14/1993
;SCREEN 106.1 -- TRANSFER TO A SPECIAL CARE UNIT
Q:$$INACTIVE^QAOC0(106.1)
S QAOSEND=QAMTODAY+.24,QAOSW=""
F S QAOSW=$O(^DPT("CN",QAOSW)) Q:QAOSW="" F QAOSDFN=0:0 S QAOSDFN=$O(^DPT("CN",QAOSW,QAOSDFN)) Q:QAOSDFN'>0 S QAOSADM=^DPT("CN",QAOSW,QAOSDFN) I QAOSADM,$D(^DGPM(QAOSADM,0))#2 D MAIN
Q
MAIN ;
S QAOSQUIT=0,QAOVISIT="" K TDATE
F QAOSTDT=9999999.9999999-QAOSEND:0 S QAOSTDT=$O(^DGPM("ATS",QAOSDFN,QAOSADM,QAOSTDT)) Q:QAOSTDT'>0!(QAOSTDT\1'?7N)!QAOSQUIT F QAOSSPEC=0:0 S QAOSSPEC=$O(^DGPM("ATS",QAOSDFN,QAOSADM,QAOSTDT,QAOSSPEC)) Q:QAOSSPEC'>0!QAOSQUIT D
. F QAOSD0P=0:0 S QAOSD0P=$O(^DGPM("ATS",QAOSDFN,QAOSADM,QAOSTDT,QAOSSPEC,QAOSD0P)) Q:QAOSD0P'>0!QAOSQUIT D LOOP1
. Q
Q
LOOP1 ;
S QAOSZERO(0)=$G(^DGPM(QAOSD0P,0)) Q:QAOSZERO(0)=""
S TRANTYPE=$P(QAOSZERO(0),"^",2) Q:TRANTYPE'=2&(TRANTYPE'=6)
G:$D(TDATE(1))#2 LOOP2
I 9999999.9999999-QAOSTDT'>(QAMTODAY-.0000001) S QAOSQUIT=1 Q
Q:$$TXSP^QAOC0("S",$P(QAOSZERO(0),"^",9))=-1
S TDATE(1)=QAOSZERO(0)
Q
LOOP2 ;
S Y=$$TXSP^QAOC0("S",$P(QAOSZERO(0),"^",9))
I $D(TDATE(2))[0,+Y>0 S QAOSQUIT=1 Q
I $D(TDATE(2))#2,+Y>0 D LOOP3 S QAOSQUIT=1 Q
S Y=$$TXSP^QAOC0("S",$P(QAOSZERO(0),"^",9))
I +Y=-1 S (TDATE(2),X2)=QAOSZERO(0),X2=+X2,X1=+TDATE(1) D ^%DTC S:X>3 QAOSQUIT=1 Q
Q
LOOP3 ;
D VADPT^QAOC0(QAOSDFN,QAOSD0P)
S QAOVISIT=9999999.9999999-QAOSTDT
S ^UTILITY($J,"QAM CONDITION",QAMD1,QAOSDFN,QAMTODAY)=""
S WARDCLIN=+VAIP(5)_"^"
S ^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"WARD")=WARDCLIN
S ^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"TXSP")=+VAIP(8)
S ^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"MVDT")=QAOVISIT
S ^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"DIAG")=VAIP(9)
S ^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"AADM")=VAIP(13)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOC1061 1902 printed Apr 09, 2024@21:22:40 Page 2
QAOC1061 ;HISC/DAD-OCCURRENCE SCREEN AUTO ENROLLMENT ;5/13/93 09:05
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 ;SCREEN 106.1 -- TRANSFER TO A SPECIAL CARE UNIT
+3 if $$INACTIVE^QAOC0(106.1)
QUIT
+4 SET QAOSEND=QAMTODAY+.24
SET QAOSW=""
+5 FOR
SET QAOSW=$ORDER(^DPT("CN",QAOSW))
if QAOSW=""
QUIT
FOR QAOSDFN=0:0
SET QAOSDFN=$ORDER(^DPT("CN",QAOSW,QAOSDFN))
if QAOSDFN'>0
QUIT
SET QAOSADM=^DPT("CN",QAOSW,QAOSDFN)
IF QAOSADM
IF $DATA(^DGPM(QAOSADM,0))#2
DO MAIN
+6 QUIT
MAIN ;
+1 SET QAOSQUIT=0
SET QAOVISIT=""
KILL TDATE
+2 FOR QAOSTDT=9999999.9999999-QAOSEND:0
SET QAOSTDT=$ORDER(^DGPM("ATS",QAOSDFN,QAOSADM,QAOSTDT))
if QAOSTDT'>0!(QAOSTDT\1'?7N)!QAOSQUIT
QUIT
FOR QAOSSPEC=0:0
SET QAOSSPEC=$ORDER(^DGPM("ATS",QAOSDFN,QAOSADM,QAOSTDT,QAOSSPEC))
if QAOSSPEC'>0!QAOSQUIT
QUIT
Begin DoDot:1
+3 FOR QAOSD0P=0:0
SET QAOSD0P=$ORDER(^DGPM("ATS",QAOSDFN,QAOSADM,QAOSTDT,QAOSSPEC,QAOSD0P))
if QAOSD0P'>0!QAOSQUIT
QUIT
DO LOOP1
+4 QUIT
End DoDot:1
+5 QUIT
LOOP1 ;
+1 SET QAOSZERO(0)=$GET(^DGPM(QAOSD0P,0))
if QAOSZERO(0)=""
QUIT
+2 SET TRANTYPE=$PIECE(QAOSZERO(0),"^",2)
if TRANTYPE'=2&(TRANTYPE'=6)
QUIT
+3 if $DATA(TDATE(1))#2
GOTO LOOP2
+4 IF 9999999.9999999-QAOSTDT'>(QAMTODAY-.0000001)
SET QAOSQUIT=1
QUIT
+5 if $$TXSP^QAOC0("S",$PIECE(QAOSZERO(0),"^",9))=-1
QUIT
+6 SET TDATE(1)=QAOSZERO(0)
+7 QUIT
LOOP2 ;
+1 SET Y=$$TXSP^QAOC0("S",$PIECE(QAOSZERO(0),"^",9))
+2 IF $DATA(TDATE(2))[0
IF +Y>0
SET QAOSQUIT=1
QUIT
+3 IF $DATA(TDATE(2))#2
IF +Y>0
DO LOOP3
SET QAOSQUIT=1
QUIT
+4 SET Y=$$TXSP^QAOC0("S",$PIECE(QAOSZERO(0),"^",9))
+5 IF +Y=-1
SET (TDATE(2),X2)=QAOSZERO(0)
SET X2=+X2
SET X1=+TDATE(1)
DO ^%DTC
if X>3
SET QAOSQUIT=1
QUIT
+6 QUIT
LOOP3 ;
+1 DO VADPT^QAOC0(QAOSDFN,QAOSD0P)
+2 SET QAOVISIT=9999999.9999999-QAOSTDT
+3 SET ^UTILITY($JOB,"QAM CONDITION",QAMD1,QAOSDFN,QAMTODAY)=""
+4 SET WARDCLIN=+VAIP(5)_"^"
+5 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"WARD")=WARDCLIN
+6 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"TXSP")=+VAIP(8)
+7 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"MVDT")=QAOVISIT
+8 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"DIAG")=VAIP(9)
+9 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"AADM")=VAIP(13)
+10 QUIT
