- GMRCONS1 ;ALB/MRY - Consult/Scheduling link report ;4/10/06 14:21
- ;;3.0;CONSULT/REQUEST TRACKING;**52,62**;DEC 27, 1997;Build 10
- EN ;
- K GMRNOSRV 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
- 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_"%")
- .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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCONS1 8446 printed Dec 13, 2024@01:46:21 Page 2
- GMRCONS1 ;ALB/MRY - Consult/Scheduling link report ;4/10/06 14:21
- +1 ;;3.0;CONSULT/REQUEST TRACKING;**52,62**;DEC 27, 1997;Build 10
- EN ;
- +1 KILL GMRNOSRV
- 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 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 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)
- +8 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
- +9 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
- +10 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