- 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 23, 2025@18:35:34 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
