GMRCONS1 ;ALB/MRY - Consult/Scheduling link report ;25-Jul-2012 11:04;DU
;;3.0;CONSULT/REQUEST TRACKING;**52,62,1003**;DEC 27, 1997;Build 14
EN ;
K GMRNOSRV,GMRTST D SERV Q:$D(GMRNOSRV)
D EN^VALM("GMRC SD PENDING CONSULTS")
Q
SERV I $D(IOTM),$D(IOBM),$D(IOSTBM) D FULL^VALM1
N XSERV
K STAT,DIC,TOT,TOTAL
K ^TMP("GMRCCS",$J)
S CNT=0
S TOTAL=0,DIC=123.5,DIC(0)="QAEMZ",DIC("A")="Select Service/Specialty: ",D="B^D" D MIX^DIC1 K DIC S:Y=-1 GMRNOSRV="" Q:Y=-1
K ST,STAT S SRVNM=Y(0,0),RS=+Y,ST="",ORD=0 F S ORD=$O(^ORD(100.01,ORD)) Q:'+ORD S STAT(ORD)=$P(^ORD(100.01,ORD,0),U)
SD S %DT="EAT",%DT("A")="Enter Starting Date: " D ^%DT S:Y=-1 GMRNOSRV="" Q:Y=-1 S PSD=Y,SD=Y-.01
S %DT="EAT",%DT("A")="Enter Ending Date: " D ^%DT S:Y=-1 GMRNOSRV="" Q:Y=-1 S ED=Y_.24
I ED<SD W !!,$C(7),"Ending Date Can Not Be Before Starting Date.",! G SD
S GMRTST=$$TESTPT^GMRCPC1()
I $D(GMRCQUT) S Y=-1 Q
Q
START D WAIT^DICD K ^TMP($J),^TMP("GMRCR",$J) S CS=RS,CNT=CNT+1,^TMP("GMRCCS",$J,CNT)=CS,^TMP("GMRCCS",$J,"B",CS)="" D SERVICE
S GRP=0 F S GRP=$O(^GMR(123.5,RS,10,GRP)) Q:'+GRP S CS=$P(^GMR(123.5,RS,10,GRP,0),U) D
.I $P(^GMR(123.5,CS,0),U,2)'=9 S CNT=CNT+1,^TMP("GMRCCS",$J,CNT)=CS,^TMP("GMRCCS",$J,"B",CS)="" D SERVICE
S ICNT=0 F S ICNT=$O(^TMP("GMRCCS",$J,ICNT)) Q:+ICNT=0 S XSERV=$G(^TMP("GMRCCS",$J,ICNT)) D SUBSERV2
K ST F I="COMPLETE","DISCONTINUED","PENDING","ACTIVE","SCHEDULED","PARTIAL RESULTS","DISCONTINUED/EDIT","CANCELLED" S TOT(I)=0
S SDI=SD F S SDI=$O(^GMR(123,"E",SDI)) Q:'+SDI!(SDI>ED) S GIEN=0 F S GIEN=$O(^GMR(123,"E",SDI,GIEN)) Q:'+GIEN S ND=^GMR(123,GIEN,0),SERV=$P(ND,U,5),STATUS=$P(ND,U,12) I SERV'="",$D(^TMP("GMRCCS",$J,"B",SERV)),$D(STAT(STATUS)) D
.S LSTACT=$P($G(^GMR(123.1,$P(ND,U,13),0)),U),PTIEN=$P(ND,U,2),ATDPT=$G(^DPT(PTIEN,0)),PTNM=$P(ATDPT,U),L4=$E($P(ATDPT,U,9),6,9),SRVCON=$P($G(^DPT(PTIEN,.3)),U,2),SRVCON=$S(SRVCON="":"",1:SRVCON_"%")
.Q:$$TESTPAT^VADPT(PTIEN)&(GMRTST="E")
.Q:'$$TESTPAT^VADPT(PTIEN)&(GMRTST="D")
.S AWAS1=$S($D(^SC("AWAS1",GIEN)):"LINKED",1:"NOT LINKED"),AHST1=$S($D(^SC("AHST1",GIEN)):"HAS HISTORY",1:"NO HISTORY"),STATS=$P(STAT(STATUS),U)
.S ^TMP($J,"S",STATS,SDI,GIEN)=PTNM_U_PTIEN_U_LSTACT_U_AWAS1_U_AHST1_U_SERV_U_STATS_U_SDI_U_L4_U_SRVCON
.S:$D(TOT(STATS)) TOT(STATS)=TOT(STATS)+1 S:'$D(TOT(STATS)) TOT(STATS)=1 S TOTAL=TOTAL+1
D ^GMRCONS2
EXIT2 K A,ACT,AD,AHST1,ATDPT,AW,AWAS1,B,CHKOT,CLNC,CMMT,CS,CSS,ED,EN,EN2,GIEN,GMRND,GRP,GXHEC,H2,HEC,HECA,HEX,I,L4,LC,LGTH,LGTH1,LSTACT,ND,ORD,ORDATE,P3,P8,P9,PTIEN,PTNM,RS,S,SC,SCDT,SCLNC,SD,SDI,SDWL,SDWLND,SERV
K SIEN,ST,STAT,STATUS,STOPCD,STPCOD,SUM,SUM2,TEXT,TND,TOT,TOTALTX,TYPE
K BB,C,CLNCNM,D,SRV,SRVNM,STATS,SUBTOT,TOTAL,TX
K PD,PSD
K ASP8,ASP9,CMHD,CNSDT,CNSLT,CNSLTND,DIC,P4,POP,PRTCNDT,SRVCON,STCD,X,Y
K CNT,ICNT,XCS,XGRP,XSERV
K ^TMP("GMRCCS",$J)
Q
SUBSERV2 ;
N CS,XCS,XGRP
S XGRP=0
F S XGRP=$O(^GMR(123.5,XSERV,10,XGRP)) Q:'+XGRP D
.S XCS=$P(^GMR(123.5,XSERV,10,XGRP,0),U)
.I $P(^GMR(123.5,XCS,0),U,2)'=9&('$D(^TMP("GMRCCS",$J,"B",XCS))) S CNT=CNT+1,^TMP("GMRCCS",$J,CNT)=XCS,^TMP("GMRCCS",$J,"B",XCS)="",CS=XCS D SERVICE
Q
SERVICE ;
S STPCLNC="",SC=0 F S SC=$O(^GMR(123.5,CS,688,SC)) Q:'+SC S STPCOD=$P(^GMR(123.5,CS,688,SC,0),U) I STPCOD'="" S STPCLNC=$P(^DIC(40.7,STPCOD,0),U)_","_STPCLNC
S SC=0 F S SC=$O(^GMR(123.5,CS,688,SC)) Q:'+SC S STPCOD=$P(^GMR(123.5,CS,688,SC,0),U) I STPCOD'="" D
.S STPCOD=$P(^DIC(40.7,STPCOD,0),U,2) S:$D(^TMP($J,"SC",STPCOD)) ^TMP($J,"SC",STPCOD)=STPCLNC_^TMP($J,"SC",STPCOD) S:'$D(^TMP($J,"SC",STPCOD)) ^TMP($J,"SC",STPCOD)=STPCLNC
Q
CLINIC ;
S CLNC=$P(^GMR(123.5,A,0),U) W @IOF,CLNC," (",A,")",!
Q
ACTIVE I '$D(^SC("AHST1",CS)) D ASP D Q
.I ASP9 S ^TMP($J,"A","ACTWOLHWL")=^TMP($J,"A","ACTWOLHWL")+1,^TMP($J,"A","ACTWOLHWL",SRV,AD,CS)=TND,WL="" D KILNODE Q
.I ASP8 S ^TMP($J,"A","ACTWOLHWL")=^TMP($J,"A","ACTWOLHWL")+1,^TMP($J,"A","ACTWOLHWL",SRV,AD,CS)=TND,WL="" D KILNODE Q
.I '$D(WL) D
..I $P($G(^GMR(123,CS,12)),U,5)="P" D
...S ^TMP($J,"A","ACTWOLHIFC")=^TMP($J,"A","ACTWOLHIFC")+1,^TMP($J,"A","ACTWOLHIFC",SRV,AD,CS)=TND
..E D
...S ^TMP($J,"A","ACTWOLHNWL",SRV,AD,CS)=TND,^TMP($J,"A","ACTWOLHNWL")=^TMP($J,"A","ACTWOLHNWL")+1
..D KILNODE Q
I LSTACT="EDIT/RESUBMITTED"!(LSTACT="ADDED COMMENT")!(LSTACT="STATUS CHANGE") K FND S EN2=$O(^GMR(123,CS,40,":"),-1),EN=":" F S EN=$O(^GMR(123,CS,40,EN),-1) Q:'+EN!($D(FND)) D EDITRSB
Q
SCHEDULE I '$D(^SC("AHST1",CS)) D ASP D Q
.I ASP9 S ^TMP($J,"A","SCHWOLHWL")=^TMP($J,"A","SCHWOLHWL")+1,^TMP($J,"A","SCHWOLHWL",SRV,AD,CS)=TND,WL="" D KILNODE Q
.I ASP8 S ^TMP($J,"A","SCHWOLHWL")=^TMP($J,"A","SCHWOLHWL")+1,^TMP($J,"A","SCHWOLHWL",SRV,AD,CS)=TND,WL="" D KILNODE Q
.I '$D(WL) D
..I $P($G(^GMR(123,CS,12)),U,5)="P" D
...S ^TMP($J,"A","SCHWOLHIFC")=^TMP($J,"A","SCHWOLHIFC")+1,^TMP($J,"A","SCHWOLHIFC",SRV,AD,CS)=TND
..E D
...S ^TMP($J,"A","SCHWOLHNWL",SRV,AD,CS)=TND,^TMP($J,"A","SCHWOLHNWL")=^TMP($J,"A","SCHWOLHNWL")+1
..D KILNODE Q
I $D(^SC("AWAS1",CS)) S AW="AWAS1" K FND S SCLNC=$O(^SC(AW,CS,":"),-1),SCDT=$O(^SC(AW,CS,SCLNC,":"),-1),SIEN=$O(^SC(AW,CS,SCLNC,SCDT,":"),-1),CSS=$P($G(^SC(SCLNC,"S",SCDT,1,SIEN,"CONS")),U) D Q
.I CSS=CS S CHKOT=$P($G(^SC(SCLNC,"S",SCDT,1,SIEN,"C")),U,3) D
..I CHKOT'="" S ^TMP($J,"A","SCHWALCO")=^TMP($J,"A","SCHWALCO")+1,^TMP($J,"A","SCHWALCO",SRV,AD,CS)=TND D KILNODE Q
..I CHKOT="" S ^TMP($J,"A","SCHWALNCO")=^TMP($J,"A","SCHWALNCO")+1,^TMP($J,"A","SCHWALNCO",SRV,AD,CS)=TND D KILNODE Q
I $D(^SC("AHST1",CS))&('$D(^SC("AWAS1",CS))) S ^TMP($J,"A","SCHWHNAL")=^TMP($J,"A","SCHWHNAL")+1,^TMP($J,"A","SCHWHNAL",SRV,AD,CS)=TND D KILNODE
Q
PENDING D ASP D
.I ASP9 S ^TMP($J,"A","PENWL")=^TMP($J,"A","PENWL")+1,^TMP($J,"A","PENWL",SRV,AD,CS)=TND,WL="" D KILNODE Q
.I ASP8 S ^TMP($J,"A","PENWL")=^TMP($J,"A","PENWL")+1,^TMP($J,"A","PENWL",SRV,AD,CS)=TND,WL="" D KILNODE Q
I '$D(WL) S ^TMP($J,"A","PENNWL")=^TMP($J,"A","PENNWL")+1,^TMP($J,"A","PENNWL",SRV,AD,CS)=TND D KILNODE
Q
ASP ;
S ASP9=0,ASP8=0,STAT="",SDWL=0 F S SDWL=$O(^SDWL(409.3,"B",PTIEN,SDWL)) Q:'+SDWL S SDWLND=$G(^SDWL(409.3,SDWL,0)),STAT=$P(SDWLND,U,17),ORDATE=$P(SDWLND,U,2) D Q:$D(WL)
.S P9=$P(SDWLND,U,9),P8=$P(SDWLND,U,8)
.I P9'="" S CLNC=$P(^SDWL(409.32,P9,0),U) I CLNC'="" S STCD=$P(^SC(CLNC,0),U,7) I STCD'="" S STOPCD=$P(^DIC(40.7,STCD,0),U,2),CLNC2=$P(^DIC(40.7,STCD,0),U) D:$D(^TMP($J,"SC",STOPCD)) Q
..I STAT="O"&(ORDATE=$P(AD,".")!(ORDATE>AD))&(STPCLNC[CLNC2) S ASP9=1 Q
.I P8'="" S CLNC=$P(^SDWL(409.31,P8,0),U) I CLNC'="" S STOPCD=$P(^DIC(40.7,CLNC,0),U,2),CLNC2=$P(^DIC(40.7,CLNC,0),U) I STOPCD'="" D:$D(^TMP($J,"SC",STOPCD)) Q
..I STAT="O"&(ORDATE=$P(AD,".")!(ORDATE>AD))&(STPCLNC[CLNC2) S ASP8=1 Q
Q
INCMPLTE S ^TMP($J,"A","INCMPLTE")=^TMP($J,"A","INCMPLTE")+1,^TMP($J,"A","INCMPLTE",SRV,AD,CS)=TND
Q
CANCELED S ^TMP($J,"A","CANCELED")=^TMP($J,"A","CANCELED")+1,^TMP($J,"A","CANCELED",SRV,AD,CS)=TND
Q
DSCNTUED S ^TMP($J,"A","DSCNTUED")=^TMP($J,"A","DSCNTUED")+1,^TMP($J,"A","DSCNTUED",SRV,AD,CS)=TND
Q
COMPLETE S ^TMP($J,"A","COMPLETE")=^TMP($J,"A","COMPLETE")+1,^TMP($J,"A","COMPLETE",SRV,AD,CS)=TND
Q
CLOSE S ^TMP($J,"A","CLOSE")=^TMP($J,"A","CLOSE")+1,^TMP($J,"A","CLOSE",SRV,AD,CS)=TND
Q
TOC S ^TMP($J,"A","TOC")=^TMP($J,"A","TOC")+1,^TMP($J,"A","TOC",SRV,AD,CS)=TND
Q
TCC S ^TMP($J,"A","TCC")=^TMP($J,"A","TCC")+1,^TMP($J,"A","TCC",SRV,AD,CS)=TND
Q
EDITRSB S GMRND=^GMR(123,CS,40,EN,0),ACT=$P(GMRND,U,2),ACT=$P(^GMR(123.1,ACT,0),U)
S:(ACT'="EDIT/RESUBMITTED")!(ACT'="STATUS CHANGE") EN2=EN I (ACT="EDIT/RESUBMITTED")!(ACT="STATUS CHANGE") D
.S CMMT=$G(^GMR(123,CS,40,EN2,1,1,0))
ACTERNS .I CMMT["was a no-show" S ^TMP($J,"A","ACTERNS")=^TMP($J,"A","ACTERNS")+1,^TMP($J,"A","ACTERNS",SRV,AD,CS)=TND,FND="" D KILNODE Q
ACTERCP .I CMMT["was cancelled by the Patient" S ^TMP($J,"A","ACTERCP")=^TMP($J,"A","ACTERCP")+1,^TMP($J,"A","ACTERCP",SRV,AD,CS)=TND,FND="" D KILNODE Q
ACTERCC .I CMMT["was cancelled by the Clinic"!(CMMT["was cancelled, whole clinic") S ^TMP($J,"A","ACTERCC")=^TMP($J,"A","ACTERCC")+1,^TMP($J,"A","ACTERCC",SRV,AD,CS)=TND,FND="" D KILNODE Q
ACTERAP .I CMMT["was cancelled for" S ^TMP($J,"A","ACTERAP")=^TMP($J,"A","ACTERAP")+1,^TMP($J,"A","ACTERAP",SRV,AD,CS)=TND,FND="" D KILNODE Q
ACTEROW .S ^TMP($J,"A","ACTEROW")=^TMP($J,"A","ACTEROW")+1,^TMP($J,"A","ACTEROW",SRV,AD,CS)=TND,FND="" D KILNODE Q
Q
KILNODE K ^TMP($J,"S",ST,AD,CS)
Q
CHKLIN I ($Y>(IOSL-4)) S HLD="" D PROMPT Q:HLD[U X CMHD S PG=PG+1
Q
IOSL Q:($Y>(IOSL-3))
PROMPT I IOST["C-" R !!,"Press enter to continue or '^' to exit. ",HLD:DTIME S PROMPT="" I HLD[" " S HLD=U
Q
GMRCONS1 ;ALB/MRY - Consult/Scheduling link report ;25-Jul-2012 11:04;DU
+1 ;;3.0;CONSULT/REQUEST TRACKING;**52,62,1003**;DEC 27, 1997;Build 14
EN ;
+1 KILL GMRNOSRV,GMRTST
DO SERV
IF $DATA(GMRNOSRV)
QUIT
+2 DO EN^VALM("GMRC SD PENDING CONSULTS")
+3 QUIT
SERV IF $DATA(IOTM)
IF $DATA(IOBM)
IF $DATA(IOSTBM)
DO FULL^VALM1
+1 NEW XSERV
+2 KILL STAT,DIC,TOT,TOTAL
+3 KILL ^TMP("GMRCCS",$JOB)
+4 SET CNT=0
+5 SET TOTAL=0
SET DIC=123.5
SET DIC(0)="QAEMZ"
SET DIC("A")="Select Service/Specialty: "
SET D="B^D"
DO MIX^DIC1
KILL DIC
IF Y=-1
SET GMRNOSRV=""
IF Y=-1
QUIT
+6 KILL ST,STAT
SET SRVNM=Y(0,0)
SET RS=+Y
SET ST=""
SET ORD=0
FOR
SET ORD=$ORDER(^ORD(100.01,ORD))
IF '+ORD
QUIT
SET STAT(ORD)=$PIECE(^ORD(100.01,ORD,0),U)
SD SET %DT="EAT"
SET %DT("A")="Enter Starting Date: "
DO ^%DT
IF Y=-1
SET GMRNOSRV=""
IF Y=-1
QUIT
SET PSD=Y
SET SD=Y-.01
+1 SET %DT="EAT"
SET %DT("A")="Enter Ending Date: "
DO ^%DT
IF Y=-1
SET GMRNOSRV=""
IF Y=-1
QUIT
SET ED=Y_.24
+2 IF ED<SD
WRITE !!,$CHAR(7),"Ending Date Can Not Be Before Starting Date.",!
GOTO SD
+3 SET GMRTST=$$TESTPT^GMRCPC1()
+4 IF $DATA(GMRCQUT)
SET Y=-1
QUIT
+5 QUIT
START DO WAIT^DICD
KILL ^TMP($JOB),^TMP("GMRCR",$JOB)
SET CS=RS
SET CNT=CNT+1
SET ^TMP("GMRCCS",$JOB,CNT)=CS
SET ^TMP("GMRCCS",$JOB,"B",CS)=""
DO SERVICE
+1 SET GRP=0
FOR
SET GRP=$ORDER(^GMR(123.5,RS,10,GRP))
IF '+GRP
QUIT
SET CS=$PIECE(^GMR(123.5,RS,10,GRP,0),U)
Begin DoDot:1
+2 IF $PIECE(^GMR(123.5,CS,0),U,2)'=9
SET CNT=CNT+1
SET ^TMP("GMRCCS",$JOB,CNT)=CS
SET ^TMP("GMRCCS",$JOB,"B",CS)=""
DO SERVICE
End DoDot:1
+3 SET ICNT=0
FOR
SET ICNT=$ORDER(^TMP("GMRCCS",$JOB,ICNT))
IF +ICNT=0
QUIT
SET XSERV=$GET(^TMP("GMRCCS",$JOB,ICNT))
DO SUBSERV2
+4 KILL ST
FOR I="COMPLETE","DISCONTINUED","PENDING","ACTIVE","SCHEDULED","PARTIAL RESULTS","DISCONTINUED/EDIT","CANCELLED"
SET TOT(I)=0
+5 SET SDI=SD
FOR
SET SDI=$ORDER(^GMR(123,"E",SDI))
IF '+SDI!(SDI>ED)
QUIT
SET GIEN=0
FOR
SET GIEN=$ORDER(^GMR(123,"E",SDI,GIEN))
IF '+GIEN
QUIT
SET ND=^GMR(123,GIEN,0)
SET SERV=$PIECE(ND,U,5)
SET STATUS=$PIECE(ND,U,12)
IF SERV'=""
IF $DATA(^TMP("GMRCCS",$JOB,"B",SERV))
IF $DATA(STAT(STATUS))
Begin DoDot:1
+6 SET LSTACT=$PIECE($GET(^GMR(123.1,$PIECE(ND,U,13),0)),U)
SET PTIEN=$PIECE(ND,U,2)
SET ATDPT=$GET(^DPT(PTIEN,0))
SET PTNM=$PIECE(ATDPT,U)
SET L4=$EXTRACT($PIECE(ATDPT,U,9),6,9)
SET SRVCON=$PIECE($GET(^DPT(PTIEN,.3)),U,2)
SET SRVCON=$SELECT(SRVCON="":"",1:SRVCON_"%")
+7 IF $$TESTPAT^VADPT(PTIEN)&(GMRTST="E")
QUIT
+8 IF '$$TESTPAT^VADPT(PTIEN)&(GMRTST="D")
QUIT
+9 SET AWAS1=$SELECT($DATA(^SC("AWAS1",GIEN)):"LINKED",1:"NOT LINKED")
SET AHST1=$SELECT($DATA(^SC("AHST1",GIEN)):"HAS HISTORY",1:"NO HISTORY")
SET STATS=$PIECE(STAT(STATUS),U)
+10 SET ^TMP($JOB,"S",STATS,SDI,GIEN)=PTNM_U_PTIEN_U_LSTACT_U_AWAS1_U_AHST1_U_SERV_U_STATS_U_SDI_U_L4_U_SRVCON
+11 IF $DATA(TOT(STATS))
SET TOT(STATS)=TOT(STATS)+1
IF '$DATA(TOT(STATS))
SET TOT(STATS)=1
SET TOTAL=TOTAL+1
End DoDot:1
+12 DO ^GMRCONS2
EXIT2 KILL A,ACT,AD,AHST1,ATDPT,AW,AWAS1,B,CHKOT,CLNC,CMMT,CS,CSS,ED,EN,EN2,GIEN,GMRND,GRP,GXHEC,H2,HEC,HECA,HEX,I,L4,LC,LGTH,LGTH1,LSTACT,ND,ORD,ORDATE,P3,P8,P9,PTIEN,PTNM,RS,S,SC,SCDT,SCLNC,SD,SDI,SDWL,SDWLND,SERV
+1 KILL SIEN,ST,STAT,STATUS,STOPCD,STPCOD,SUM,SUM2,TEXT,TND,TOT,TOTALTX,TYPE
+2 KILL BB,C,CLNCNM,D,SRV,SRVNM,STATS,SUBTOT,TOTAL,TX
+3 KILL PD,PSD
+4 KILL ASP8,ASP9,CMHD,CNSDT,CNSLT,CNSLTND,DIC,P4,POP,PRTCNDT,SRVCON,STCD,X,Y
+5 KILL CNT,ICNT,XCS,XGRP,XSERV
+6 KILL ^TMP("GMRCCS",$JOB)
+7 QUIT
SUBSERV2 ;
+1 NEW CS,XCS,XGRP
+2 SET XGRP=0
+3 FOR
SET XGRP=$ORDER(^GMR(123.5,XSERV,10,XGRP))
IF '+XGRP
QUIT
Begin DoDot:1
+4 SET XCS=$PIECE(^GMR(123.5,XSERV,10,XGRP,0),U)
+5 IF $PIECE(^GMR(123.5,XCS,0),U,2)'=9&('$DATA(^TMP("GMRCCS",$JOB,"B",XCS)))
SET CNT=CNT+1
SET ^TMP("GMRCCS",$JOB,CNT)=XCS
SET ^TMP("GMRCCS",$JOB,"B",XCS)=""
SET CS=XCS
DO SERVICE
End DoDot:1
+6 QUIT
SERVICE ;
+1 SET STPCLNC=""
SET SC=0
FOR
SET SC=$ORDER(^GMR(123.5,CS,688,SC))
IF '+SC
QUIT
SET STPCOD=$PIECE(^GMR(123.5,CS,688,SC,0),U)
IF STPCOD'=""
SET STPCLNC=$PIECE(^DIC(40.7,STPCOD,0),U)_","_STPCLNC
+2 SET SC=0
FOR
SET SC=$ORDER(^GMR(123.5,CS,688,SC))
IF '+SC
QUIT
SET STPCOD=$PIECE(^GMR(123.5,CS,688,SC,0),U)
IF STPCOD'=""
Begin DoDot:1
+3 SET STPCOD=$PIECE(^DIC(40.7,STPCOD,0),U,2)
IF $DATA(^TMP($JOB,"SC",STPCOD))
SET ^TMP($JOB,"SC",STPCOD)=STPCLNC_^TMP($JOB,"SC",STPCOD)
IF '$DATA(^TMP($JOB,"SC",STPCOD))
SET ^TMP($JOB,"SC",STPCOD)=STPCLNC
End DoDot:1
+4 QUIT
CLINIC ;
+1 SET CLNC=$PIECE(^GMR(123.5,A,0),U)
WRITE @IOF,CLNC," (",A,")",!
+2 QUIT
ACTIVE IF '$DATA(^SC("AHST1",CS))
DO ASP
Begin DoDot:1
+1 IF ASP9
SET ^TMP($JOB,"A","ACTWOLHWL")=^TMP($JOB,"A","ACTWOLHWL")+1
SET ^TMP($JOB,"A","ACTWOLHWL",SRV,AD,CS)=TND
SET WL=""
DO KILNODE
QUIT
+2 IF ASP8
SET ^TMP($JOB,"A","ACTWOLHWL")=^TMP($JOB,"A","ACTWOLHWL")+1
SET ^TMP($JOB,"A","ACTWOLHWL",SRV,AD,CS)=TND
SET WL=""
DO KILNODE
QUIT
+3 IF '$DATA(WL)
Begin DoDot:2
+4 IF $PIECE($GET(^GMR(123,CS,12)),U,5)="P"
Begin DoDot:3
+5 SET ^TMP($JOB,"A","ACTWOLHIFC")=^TMP($JOB,"A","ACTWOLHIFC")+1
SET ^TMP($JOB,"A","ACTWOLHIFC",SRV,AD,CS)=TND
End DoDot:3
+6 IF '$TEST
Begin DoDot:3
+7 SET ^TMP($JOB,"A","ACTWOLHNWL",SRV,AD,CS)=TND
SET ^TMP($JOB,"A","ACTWOLHNWL")=^TMP($JOB,"A","ACTWOLHNWL")+1
End DoDot:3
+8 DO KILNODE
QUIT
End DoDot:2
End DoDot:1
QUIT
+9 IF LSTACT="EDIT/RESUBMITTED"!(LSTACT="ADDED COMMENT")!(LSTACT="STATUS CHANGE")
KILL FND
SET EN2=$ORDER(^GMR(123,CS,40,":"),-1)
SET EN=":"
FOR
SET EN=$ORDER(^GMR(123,CS,40,EN),-1)
IF '+EN!($DATA(FND))
QUIT
DO EDITRSB
+10 QUIT
SCHEDULE IF '$DATA(^SC("AHST1",CS))
DO ASP
Begin DoDot:1
+1 IF ASP9
SET ^TMP($JOB,"A","SCHWOLHWL")=^TMP($JOB,"A","SCHWOLHWL")+1
SET ^TMP($JOB,"A","SCHWOLHWL",SRV,AD,CS)=TND
SET WL=""
DO KILNODE
QUIT
+2 IF ASP8
SET ^TMP($JOB,"A","SCHWOLHWL")=^TMP($JOB,"A","SCHWOLHWL")+1
SET ^TMP($JOB,"A","SCHWOLHWL",SRV,AD,CS)=TND
SET WL=""
DO KILNODE
QUIT
+3 IF '$DATA(WL)
Begin DoDot:2
+4 IF $PIECE($GET(^GMR(123,CS,12)),U,5)="P"
Begin DoDot:3
+5 SET ^TMP($JOB,"A","SCHWOLHIFC")=^TMP($JOB,"A","SCHWOLHIFC")+1
SET ^TMP($JOB,"A","SCHWOLHIFC",SRV,AD,CS)=TND
End DoDot:3
+6 IF '$TEST
Begin DoDot:3
+7 SET ^TMP($JOB,"A","SCHWOLHNWL",SRV,AD,CS)=TND
SET ^TMP($JOB,"A","SCHWOLHNWL")=^TMP($JOB,"A","SCHWOLHNWL")+1
End DoDot:3
+8 DO KILNODE
QUIT
End DoDot:2
End DoDot:1
QUIT
+9 IF $DATA(^SC("AWAS1",CS))
SET AW="AWAS1"
KILL FND
SET SCLNC=$ORDER(^SC(AW,CS,":"),-1)
SET SCDT=$ORDER(^SC(AW,CS,SCLNC,":"),-1)
SET SIEN=$ORDER(^SC(AW,CS,SCLNC,SCDT,":"),-1)
SET CSS=$PIECE($GET(^SC(SCLNC,"S",SCDT,1,SIEN,"CONS")),U)
Begin DoDot:1
+10 IF CSS=CS
SET CHKOT=$PIECE($GET(^SC(SCLNC,"S",SCDT,1,SIEN,"C")),U,3)
Begin DoDot:2
+11 IF CHKOT'=""
SET ^TMP($JOB,"A","SCHWALCO")=^TMP($JOB,"A","SCHWALCO")+1
SET ^TMP($JOB,"A","SCHWALCO",SRV,AD,CS)=TND
DO KILNODE
QUIT
+12 IF CHKOT=""
SET ^TMP($JOB,"A","SCHWALNCO")=^TMP($JOB,"A","SCHWALNCO")+1
SET ^TMP($JOB,"A","SCHWALNCO",SRV,AD,CS)=TND
DO KILNODE
QUIT
End DoDot:2
End DoDot:1
QUIT
+13 IF $DATA(^SC("AHST1",CS))&('$DATA(^SC("AWAS1",CS)))
SET ^TMP($JOB,"A","SCHWHNAL")=^TMP($JOB,"A","SCHWHNAL")+1
SET ^TMP($JOB,"A","SCHWHNAL",SRV,AD,CS)=TND
DO KILNODE
+14 QUIT
PENDING DO ASP
Begin DoDot:1
+1 IF ASP9
SET ^TMP($JOB,"A","PENWL")=^TMP($JOB,"A","PENWL")+1
SET ^TMP($JOB,"A","PENWL",SRV,AD,CS)=TND
SET WL=""
DO KILNODE
QUIT
+2 IF ASP8
SET ^TMP($JOB,"A","PENWL")=^TMP($JOB,"A","PENWL")+1
SET ^TMP($JOB,"A","PENWL",SRV,AD,CS)=TND
SET WL=""
DO KILNODE
QUIT
End DoDot:1
+3 IF '$DATA(WL)
SET ^TMP($JOB,"A","PENNWL")=^TMP($JOB,"A","PENNWL")+1
SET ^TMP($JOB,"A","PENNWL",SRV,AD,CS)=TND
DO KILNODE
+4 QUIT
ASP ;
+1 SET ASP9=0
SET ASP8=0
SET STAT=""
SET SDWL=0
FOR
SET SDWL=$ORDER(^SDWL(409.3,"B",PTIEN,SDWL))
IF '+SDWL
QUIT
SET SDWLND=$GET(^SDWL(409.3,SDWL,0))
SET STAT=$PIECE(SDWLND,U,17)
SET ORDATE=$PIECE(SDWLND,U,2)
Begin DoDot:1
+2 SET P9=$PIECE(SDWLND,U,9)
SET P8=$PIECE(SDWLND,U,8)
+3 IF P9'=""
SET CLNC=$PIECE(^SDWL(409.32,P9,0),U)
IF CLNC'=""
SET STCD=$PIECE(^SC(CLNC,0),U,7)
IF STCD'=""
SET STOPCD=$PIECE(^DIC(40.7,STCD,0),U,2)
SET CLNC2=$PIECE(^DIC(40.7,STCD,0),U)
IF $DATA(^TMP($JOB,"SC",STOPCD))
Begin DoDot:2
+4 IF STAT="O"&(ORDATE=$PIECE(AD,".")!(ORDATE>AD))&(STPCLNC[CLNC2)
SET ASP9=1
QUIT
End DoDot:2
QUIT
+5 IF P8'=""
SET CLNC=$PIECE(^SDWL(409.31,P8,0),U)
IF CLNC'=""
SET STOPCD=$PIECE(^DIC(40.7,CLNC,0),U,2)
SET CLNC2=$PIECE(^DIC(40.7,CLNC,0),U)
IF STOPCD'=""
IF $DATA(^TMP($JOB,"SC",STOPCD))
Begin DoDot:2
+6 IF STAT="O"&(ORDATE=$PIECE(AD,".")!(ORDATE>AD))&(STPCLNC[CLNC2)
SET ASP8=1
QUIT
End DoDot:2
QUIT
End DoDot:1
IF $DATA(WL)
QUIT
+7 QUIT
INCMPLTE SET ^TMP($JOB,"A","INCMPLTE")=^TMP($JOB,"A","INCMPLTE")+1
SET ^TMP($JOB,"A","INCMPLTE",SRV,AD,CS)=TND
+1 QUIT
CANCELED SET ^TMP($JOB,"A","CANCELED")=^TMP($JOB,"A","CANCELED")+1
SET ^TMP($JOB,"A","CANCELED",SRV,AD,CS)=TND
+1 QUIT
DSCNTUED SET ^TMP($JOB,"A","DSCNTUED")=^TMP($JOB,"A","DSCNTUED")+1
SET ^TMP($JOB,"A","DSCNTUED",SRV,AD,CS)=TND
+1 QUIT
COMPLETE SET ^TMP($JOB,"A","COMPLETE")=^TMP($JOB,"A","COMPLETE")+1
SET ^TMP($JOB,"A","COMPLETE",SRV,AD,CS)=TND
+1 QUIT
CLOSE SET ^TMP($JOB,"A","CLOSE")=^TMP($JOB,"A","CLOSE")+1
SET ^TMP($JOB,"A","CLOSE",SRV,AD,CS)=TND
+1 QUIT
TOC SET ^TMP($JOB,"A","TOC")=^TMP($JOB,"A","TOC")+1
SET ^TMP($JOB,"A","TOC",SRV,AD,CS)=TND
+1 QUIT
TCC SET ^TMP($JOB,"A","TCC")=^TMP($JOB,"A","TCC")+1
SET ^TMP($JOB,"A","TCC",SRV,AD,CS)=TND
+1 QUIT
EDITRSB SET GMRND=^GMR(123,CS,40,EN,0)
SET ACT=$PIECE(GMRND,U,2)
SET ACT=$PIECE(^GMR(123.1,ACT,0),U)
+1 IF (ACT'="EDIT/RESUBMITTED")!(ACT'="STATUS CHANGE")
SET EN2=EN
IF (ACT="EDIT/RESUBMITTED")!(ACT="STATUS CHANGE")
Begin DoDot:1
+2 SET CMMT=$GET(^GMR(123,CS,40,EN2,1,1,0))
ACTERNS IF CMMT["was a no-show"
SET ^TMP($JOB,"A","ACTERNS")=^TMP($JOB,"A","ACTERNS")+1
SET ^TMP($JOB,"A","ACTERNS",SRV,AD,CS)=TND
SET FND=""
DO KILNODE
QUIT
ACTERCP IF CMMT["was cancelled by the Patient"
SET ^TMP($JOB,"A","ACTERCP")=^TMP($JOB,"A","ACTERCP")+1
SET ^TMP($JOB,"A","ACTERCP",SRV,AD,CS)=TND
SET FND=""
DO KILNODE
QUIT
ACTERCC IF CMMT["was cancelled by the Clinic"!(CMMT["was cancelled, whole clinic")
SET ^TMP($JOB,"A","ACTERCC")=^TMP($JOB,"A","ACTERCC")+1
SET ^TMP($JOB,"A","ACTERCC",SRV,AD,CS)=TND
SET FND=""
DO KILNODE
QUIT
ACTERAP IF CMMT["was cancelled for"
SET ^TMP($JOB,"A","ACTERAP")=^TMP($JOB,"A","ACTERAP")+1
SET ^TMP($JOB,"A","ACTERAP",SRV,AD,CS)=TND
SET FND=""
DO KILNODE
QUIT
ACTEROW SET ^TMP($JOB,"A","ACTEROW")=^TMP($JOB,"A","ACTEROW")+1
SET ^TMP($JOB,"A","ACTEROW",SRV,AD,CS)=TND
SET FND=""
DO KILNODE
QUIT
End DoDot:1
+1 QUIT
KILNODE KILL ^TMP($JOB,"S",ST,AD,CS)
+1 QUIT
CHKLIN IF ($Y>(IOSL-4))
SET HLD=""
DO PROMPT
IF HLD[U
QUIT
XECUTE CMHD
SET PG=PG+1
+1 QUIT
IOSL IF ($Y>(IOSL-3))
QUIT
PROMPT IF IOST["C-"
READ !!,"Press enter to continue or '^' to exit. ",HLD:DTIME
SET PROMPT=""
IF HLD[" "
SET HLD=U
+1 QUIT
