SDCO0 ;ALB/RMO - Build List Area - Check Out;11 FEB 1993 10:00 am ; 6/22/05 12:56pm
;;5.3;Scheduling;**20,44,132,180,351,441,586**;Aug 13, 1993;Build 28
;
EN(SDARY,SDOE,SDSTART,SDTOT) ;Entry point Called by Ck Out & Apt Mgr Exp Dis
S SDTOT=0
D CL(SDARY,SDOE,SDSTART,.SDTOT)
D PR(SDARY,SDOE,SDSTART,.SDTOT)
D DX(SDARY,SDOE,SDSTART,.SDTOT)
I $P($G(^SCE(+SDOE,0)),"^",8)'=2 D SC(SDARY,SDOE,SDSTART,.SDTOT)
Q
;
CL(SDARY,SDOE,SDSTART,SDTOT) ;Build classification (Pg: 1 Row: SDSTART-SDSTART+7 Col: 1-80)
N SDCLOEY,SDCNI,SDCNT,SDCTI,SDCTIS,SDCTS,SDEND,SDLINE,SDNA,SDVAL,X
S SDLINE=SDSTART,SDEND=SDSTART+8
D SET(SDARY,SDLINE," CLASSIFICATION ",5,IORVON,IORVOFF,"","","",.SDTOT)
D CLASK^SDCO2(SDOE,.SDCLOEY)
D SET(SDARY,SDLINE,"["_$S($D(SDCLOEY):"Required",1:"Not Required")_"]",24,"","","","","",.SDTOT)
S SDCNT=0,SDCTIS=$$SEQ^SDCO21
F SDCTS=1:1 S SDCTI=+$P(SDCTIS,",",SDCTS) Q:'SDCTI D
.S SDCNT=SDCNT+1,SDLINE=SDLINE+1
.S:$D(SDCLOEY(SDCTI)) SDVAL=$$VAL^SDCODD(SDCTI,$P(SDCLOEY(SDCTI),"^",2)),SDNA=+$P(SDCLOEY(SDCTI),"^",3)
.S X=$S('$D(SDCLOEY(SDCTI)):"Not Applicable",$$COMDT^SDCOU(SDOE)&(SDVAL=""):"Not Applicable",SDVAL="":"Unanswered",1:SDVAL)
.D SET(SDARY,SDLINE,SDCNT_" "_$J($P($G(^SD(409.41,SDCTI,0)),"^",6)_": ",32)_X,2,"","","CL",SDCNT,+$G(SDCLOEY(SDCTI))_"^"_SDCTI,.SDTOT)
F SDLINE=SDLINE+1:1:SDEND D SET(SDARY,SDLINE,"",1,"","","","","",.SDTOT)
Q
;
PR(SDARY,SDOE,SDSTART,SDTOT) ;Build Provider (Pg: 1 Row: SDSTART+8-END Col: 1-40)
N SDCNT,SDLINE,SDPR,SDVPRV
S SDLINE=SDSTART+9
D SET(SDARY,SDLINE," PROVIDER ",5,IORVON,IORVOFF,"","","",.SDTOT)
D SET(SDARY,SDLINE,"["_$S($$PRASK^SDCO3(SDOE)=1:"Required",1:"Not Required")_"]",18,"","","","","",.SDTOT)
;
; -- get provider data
D GETPRV^SDOE(SDOE,"SDPR")
S (SDCNT,SDVPRV)=0
F S SDVPRV=$O(SDPR(SDVPRV)) Q:'SDVPRV D
. S SDCNT=SDCNT+1
. S SDLINE=SDLINE+1
. D SET(SDARY,SDLINE,SDCNT_" "_$$PR^SDCO31(+SDPR(SDVPRV)),2,"","","PR",SDCNT,SDVPRV_"^"_+SDPR(SDVPRV),.SDTOT)
Q
;
DX(SDARY,SDOE,SDSTART,SDTOT) ;Build Diagnosis (Pg: 1 Row: SDSTART+8-END Col: 42-80)
N SDCNT,SDDXS,SDDXD,SDVPOV,SDLINE,ICDVDT,IMPDT,DXARY,TXT,I
S SDLINE=SDSTART+9
D SET(SDARY,SDLINE," DIAGNOSIS ",45,IORVON,IORVOFF,"","","",.SDTOT)
D SET(SDARY,SDLINE,"["_$S($$DXASK^SDCO4(SDOE)=1:"Required",1:"Not Required")_"]",59,"","","","","",.SDTOT)
;
; -- get dxs data
D GETDX^SDOE(SDOE,"SDDXS")
S (SDCNT,SDVPOV)=0
S IMPDT=$$IMP^ICDEX(30)
F S SDVPOV=$O(SDDXS(SDVPOV)) Q:'SDVPOV D
. S SDCNT=SDCNT+1
. S SDLINE=SDLINE+1
. S ICDVDT=$S($P(SDDXS(SDVPOV),"^",3)'="":$$GET1^DIQ(9000010,$P(SDDXS(SDVPOV),"^",3),.01,"I"),1:"")
. S SDDXD=$$DX^SDCO41(+SDDXS(SDVPOV),ICDVDT)
. D SET(SDARY,SDLINE,SDCNT_" "_$P(SDDXD,"^"),42,"","","","","",.SDTOT)
. I ICDVDT<IMPDT D Q
. . D SET(SDARY,SDLINE,$P(SDDXD,"^",2),55,"","","DX",SDCNT,SDVPOV_"^"_+SDDXS(SDVPOV),.SDTOT)
. D DXFTXT($P(SDDXD,"^",2),.DXARY) S I="" F S I=$O(DXARY(I)) Q:I="" S TXT=DXARY(I) D
. . I I=1 D SET(SDARY,SDLINE,TXT,55,"","","DX",SDCNT,SDVPOV_"^"_+SDDXS(SDVPOV),.SDTOT) Q
. . S SDLINE=SDLINE+1 D SET(SDARY,SDLINE,TXT,55,"","","","","",.SDTOT)
Q
;
SC(SDARY,SDOEP,SDSTART,SDTOT) ;Build Stop Codes (Pg: 2 Row: SDTOT+1 Col: 1-80)
N SDLINE,SDONE
F SDLINE=SDTOT+1:1:SDSTART+VALM("LINES")+1 D SET(SDARY,SDLINE,"",1,"","","","","",.SDTOT)
D SET(SDARY,SDLINE," STOP CODES ",5,IORVON,IORVOFF,"","","",.SDTOT)
D SET(SDARY,SDLINE,"[Stop Codes Not Required / Procedures Required]",28,"","","","","",.SDTOT)
D AE(SDARY,SDOEP,.SDLINE,.SDTOT,.SDONE)
S SDOE=0
F S SDOE=$O(^SCE("APAR",SDOEP,SDOE)) Q:'SDOE D AE(SDARY,SDOE,.SDLINE,.SDTOT,.SDONE)
Q
;
AE(SDARY,SDOE,SDLINE,SDTOT,SDONE) ; -- add/edits
N SDOE0,SDT,DFN,SDVIEN,CPTS,SDCNT,SDVCPT0,SDVCPT,SDSCD0,X
S SDOE0=$G(^SCE(+SDOE,0))
S SDT=+SDOE0
S DFN=+$P(SDOE0,"^",2)
S SDSC=+$P(SDOE0,U,3)
S SDCL=+$P(SDOE0,U,4)
S SDVIEN=+$P(SDOE0,U,5)
;
; -- quit if visit already processed
G:$D(SDONE(SDVIEN)) AEQ
;
S SDSCD0=$G(^DIC(40.7,SDSC,0))
S SDLINE=SDLINE+1
D SET(SDARY,SDLINE,$P(SDSCD0,"^",2)_" "_$E($P(SDSCD0,"^"),1,30),5,"","","","","",.SDTOT)
;
; -- get cpts and loop
D GETCPT^SDOE(SDOE,"CPTS")
S (SDCNT,SDVCPT)=0
N MODINFO,MODPTR,MODTEXT,PTR,MODCODE,CPTINFO,ICPTVDT
F S SDVCPT=+$O(CPTS(SDVCPT)) Q:'SDVCPT D
.; S SDVCPT0=$G(CPTS(SDVCPT))
.; S SDCNT=SDCNT+1
. S SDLINE=SDLINE+1
. D SET(SDARY,SDLINE,"Procedure(s):",12,"","","","","",.SDTOT)
.;
.; IF $D(^ICPT(+SDVCPT0,0)) S X=^(0) D
.; N CPTINFO
. S ICPTVDT=$S($P(CPTS(SDVCPT),"^",3)'="":$$GET1^DIQ(9000010,$P(CPTS(SDVCPT),"^",3),.01,"I"),1:"")
. S CPTINFO=$$CPT^ICPTCOD(+$G(CPTS(SDVCPT)),ICPTVDT,1)
. S:CPTINFO>0 X=$P(CPTINFO,"^",2,99),X=$P(X,"^")_" x "_$P($G(CPTS(SDVCPT)),"^",16)_" "_$P(X,"^",2)
. S:CPTINFO'>0 X="Procedure not defined"
. ;
. D SET(SDARY,SDLINE,$E(X,1,40),27,"","","","","",.SDTOT)
. ;
. ;Retrieve Procedure (CPT) Codes and associated Modifiers
. S PTR=0
. F S PTR=+$O(CPTS(SDVCPT,1,PTR)) Q:'PTR D
. . S MODPTR=$G(CPTS(SDVCPT,1,PTR,0))
. . Q:'MODPTR
. . S MODINFO=$$MOD^ICPTMOD(MODPTR,"I",ICPTVDT,1)
. . Q:MODINFO'>0
. . S MODCODE="-"_$P(MODINFO,"^",2)
. . S MODTEXT=$P(MODINFO,"^",3)
. . S SDLINE=SDLINE+1
. . D SET(SDARY,SDLINE,MODCODE,29,"","","","","",.SDTOT)
. . D SET(SDARY,SDLINE,MODTEXT,38,"","","","","",.SDTOT)
. . Q
;
; -- set indicator that visit was processed
S SDONE(SDVIEN)=""
AEQ Q
;
SET(SDARY,LINE,TEXT,COL,ON,OFF,SDSUB,SDCNT,SDATA,SDTOT) ; -- set display array
N X
S:LINE>SDTOT SDTOT=LINE
S X=$S($D(^TMP(SDARY,$J,LINE,0)):^(0),1:"")
S ^TMP(SDARY,$J,LINE,0)=$$SETSTR^VALM1(TEXT,X,COL,$L(TEXT))
D:$G(ON)]""!($G(OFF)]"") CNTRL^VALM10(LINE,COL,$L(TEXT),$G(ON),$G(OFF))
S:$G(SDSUB)]"" ^TMP("SDCOIDX",$J,SDSUB,SDCNT,SDLINE)=SDATA,^TMP("SDCOIDX",$J,SDSUB,0)=SDCNT
Q
DXFTXT(DXTXT,DXARY) ; -- formatted diagnosis text
N DIWL,DIWR,X
K ^UTILITY($J,"W"),DXARY
S DIWL=1,DIWR=26,X=$$SENTENCE^XLFSTR(DXTXT)
D ^DIWP
S X=""
F S X=$O(^UTILITY($J,"W",1,X)) Q:X="" D
. S DXARY(X)=$G(^UTILITY($J,"W",1,X,0))
K ^UTILITY($J,"W")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDCO0 6087 printed Dec 13, 2024@02:49:16 Page 2
SDCO0 ;ALB/RMO - Build List Area - Check Out;11 FEB 1993 10:00 am ; 6/22/05 12:56pm
+1 ;;5.3;Scheduling;**20,44,132,180,351,441,586**;Aug 13, 1993;Build 28
+2 ;
EN(SDARY,SDOE,SDSTART,SDTOT) ;Entry point Called by Ck Out & Apt Mgr Exp Dis
+1 SET SDTOT=0
+2 DO CL(SDARY,SDOE,SDSTART,.SDTOT)
+3 DO PR(SDARY,SDOE,SDSTART,.SDTOT)
+4 DO DX(SDARY,SDOE,SDSTART,.SDTOT)
+5 IF $PIECE($GET(^SCE(+SDOE,0)),"^",8)'=2
DO SC(SDARY,SDOE,SDSTART,.SDTOT)
+6 QUIT
+7 ;
CL(SDARY,SDOE,SDSTART,SDTOT) ;Build classification (Pg: 1 Row: SDSTART-SDSTART+7 Col: 1-80)
+1 NEW SDCLOEY,SDCNI,SDCNT,SDCTI,SDCTIS,SDCTS,SDEND,SDLINE,SDNA,SDVAL,X
+2 SET SDLINE=SDSTART
SET SDEND=SDSTART+8
+3 DO SET(SDARY,SDLINE," CLASSIFICATION ",5,IORVON,IORVOFF,"","","",.SDTOT)
+4 DO CLASK^SDCO2(SDOE,.SDCLOEY)
+5 DO SET(SDARY,SDLINE,"["_$SELECT($DATA(SDCLOEY):"Required",1:"Not Required")_"]",24,"","","","","",.SDTOT)
+6 SET SDCNT=0
SET SDCTIS=$$SEQ^SDCO21
+7 FOR SDCTS=1:1
SET SDCTI=+$PIECE(SDCTIS,",",SDCTS)
if 'SDCTI
QUIT
Begin DoDot:1
+8 SET SDCNT=SDCNT+1
SET SDLINE=SDLINE+1
+9 if $DATA(SDCLOEY(SDCTI))
SET SDVAL=$$VAL^SDCODD(SDCTI,$PIECE(SDCLOEY(SDCTI),"^",2))
SET SDNA=+$PIECE(SDCLOEY(SDCTI),"^",3)
+10 SET X=$SELECT('$DATA(SDCLOEY(SDCTI)):"Not Applicable",$$COMDT^SDCOU(SDOE)&(SDVAL=""):"Not Applicable",SDVAL="":"Unanswered",1:SDVAL)
+11 DO SET(SDARY,SDLINE,SDCNT_" "_$JUSTIFY($PIECE($GET(^SD(409.41,SDCTI,0)),"^",6)_": ",32)_X,2,"","","CL",SDCNT,+$GET(SDCLOEY(SDCTI))_"^"_SDCTI,.SDTOT)
End DoDot:1
+12 FOR SDLINE=SDLINE+1:1:SDEND
DO SET(SDARY,SDLINE,"",1,"","","","","",.SDTOT)
+13 QUIT
+14 ;
PR(SDARY,SDOE,SDSTART,SDTOT) ;Build Provider (Pg: 1 Row: SDSTART+8-END Col: 1-40)
+1 NEW SDCNT,SDLINE,SDPR,SDVPRV
+2 SET SDLINE=SDSTART+9
+3 DO SET(SDARY,SDLINE," PROVIDER ",5,IORVON,IORVOFF,"","","",.SDTOT)
+4 DO SET(SDARY,SDLINE,"["_$SELECT($$PRASK^SDCO3(SDOE)=1:"Required",1:"Not Required")_"]",18,"","","","","",.SDTOT)
+5 ;
+6 ; -- get provider data
+7 DO GETPRV^SDOE(SDOE,"SDPR")
+8 SET (SDCNT,SDVPRV)=0
+9 FOR
SET SDVPRV=$ORDER(SDPR(SDVPRV))
if 'SDVPRV
QUIT
Begin DoDot:1
+10 SET SDCNT=SDCNT+1
+11 SET SDLINE=SDLINE+1
+12 DO SET(SDARY,SDLINE,SDCNT_" "_$$PR^SDCO31(+SDPR(SDVPRV)),2,"","","PR",SDCNT,SDVPRV_"^"_+SDPR(SDVPRV),.SDTOT)
End DoDot:1
+13 QUIT
+14 ;
DX(SDARY,SDOE,SDSTART,SDTOT) ;Build Diagnosis (Pg: 1 Row: SDSTART+8-END Col: 42-80)
+1 NEW SDCNT,SDDXS,SDDXD,SDVPOV,SDLINE,ICDVDT,IMPDT,DXARY,TXT,I
+2 SET SDLINE=SDSTART+9
+3 DO SET(SDARY,SDLINE," DIAGNOSIS ",45,IORVON,IORVOFF,"","","",.SDTOT)
+4 DO SET(SDARY,SDLINE,"["_$SELECT($$DXASK^SDCO4(SDOE)=1:"Required",1:"Not Required")_"]",59,"","","","","",.SDTOT)
+5 ;
+6 ; -- get dxs data
+7 DO GETDX^SDOE(SDOE,"SDDXS")
+8 SET (SDCNT,SDVPOV)=0
+9 SET IMPDT=$$IMP^ICDEX(30)
+10 FOR
SET SDVPOV=$ORDER(SDDXS(SDVPOV))
if 'SDVPOV
QUIT
Begin DoDot:1
+11 SET SDCNT=SDCNT+1
+12 SET SDLINE=SDLINE+1
+13 SET ICDVDT=$SELECT($PIECE(SDDXS(SDVPOV),"^",3)'="":$$GET1^DIQ(9000010,$PIECE(SDDXS(SDVPOV),"^",3),.01,"I"),1:"")
+14 SET SDDXD=$$DX^SDCO41(+SDDXS(SDVPOV),ICDVDT)
+15 DO SET(SDARY,SDLINE,SDCNT_" "_$PIECE(SDDXD,"^"),42,"","","","","",.SDTOT)
+16 IF ICDVDT<IMPDT
Begin DoDot:2
+17 DO SET(SDARY,SDLINE,$PIECE(SDDXD,"^",2),55,"","","DX",SDCNT,SDVPOV_"^"_+SDDXS(SDVPOV),.SDTOT)
End DoDot:2
QUIT
+18 DO DXFTXT($PIECE(SDDXD,"^",2),.DXARY)
SET I=""
FOR
SET I=$ORDER(DXARY(I))
if I=""
QUIT
SET TXT=DXARY(I)
Begin DoDot:2
+19 IF I=1
DO SET(SDARY,SDLINE,TXT,55,"","","DX",SDCNT,SDVPOV_"^"_+SDDXS(SDVPOV),.SDTOT)
QUIT
+20 SET SDLINE=SDLINE+1
DO SET(SDARY,SDLINE,TXT,55,"","","","","",.SDTOT)
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
SC(SDARY,SDOEP,SDSTART,SDTOT) ;Build Stop Codes (Pg: 2 Row: SDTOT+1 Col: 1-80)
+1 NEW SDLINE,SDONE
+2 FOR SDLINE=SDTOT+1:1:SDSTART+VALM("LINES")+1
DO SET(SDARY,SDLINE,"",1,"","","","","",.SDTOT)
+3 DO SET(SDARY,SDLINE," STOP CODES ",5,IORVON,IORVOFF,"","","",.SDTOT)
+4 DO SET(SDARY,SDLINE,"[Stop Codes Not Required / Procedures Required]",28,"","","","","",.SDTOT)
+5 DO AE(SDARY,SDOEP,.SDLINE,.SDTOT,.SDONE)
+6 SET SDOE=0
+7 FOR
SET SDOE=$ORDER(^SCE("APAR",SDOEP,SDOE))
if 'SDOE
QUIT
DO AE(SDARY,SDOE,.SDLINE,.SDTOT,.SDONE)
+8 QUIT
+9 ;
AE(SDARY,SDOE,SDLINE,SDTOT,SDONE) ; -- add/edits
+1 NEW SDOE0,SDT,DFN,SDVIEN,CPTS,SDCNT,SDVCPT0,SDVCPT,SDSCD0,X
+2 SET SDOE0=$GET(^SCE(+SDOE,0))
+3 SET SDT=+SDOE0
+4 SET DFN=+$PIECE(SDOE0,"^",2)
+5 SET SDSC=+$PIECE(SDOE0,U,3)
+6 SET SDCL=+$PIECE(SDOE0,U,4)
+7 SET SDVIEN=+$PIECE(SDOE0,U,5)
+8 ;
+9 ; -- quit if visit already processed
+10 if $DATA(SDONE(SDVIEN))
GOTO AEQ
+11 ;
+12 SET SDSCD0=$GET(^DIC(40.7,SDSC,0))
+13 SET SDLINE=SDLINE+1
+14 DO SET(SDARY,SDLINE,$PIECE(SDSCD0,"^",2)_" "_$EXTRACT($PIECE(SDSCD0,"^"),1,30),5,"","","","","",.SDTOT)
+15 ;
+16 ; -- get cpts and loop
+17 DO GETCPT^SDOE(SDOE,"CPTS")
+18 SET (SDCNT,SDVCPT)=0
+19 NEW MODINFO,MODPTR,MODTEXT,PTR,MODCODE,CPTINFO,ICPTVDT
+20 FOR
SET SDVCPT=+$ORDER(CPTS(SDVCPT))
if 'SDVCPT
QUIT
Begin DoDot:1
+21 ; S SDVCPT0=$G(CPTS(SDVCPT))
+22 ; S SDCNT=SDCNT+1
+23 SET SDLINE=SDLINE+1
+24 DO SET(SDARY,SDLINE,"Procedure(s):",12,"","","","","",.SDTOT)
+25 ;
+26 ; IF $D(^ICPT(+SDVCPT0,0)) S X=^(0) D
+27 ; N CPTINFO
+28 SET ICPTVDT=$SELECT($PIECE(CPTS(SDVCPT),"^",3)'="":$$GET1^DIQ(9000010,$PIECE(CPTS(SDVCPT),"^",3),.01,"I"),1:"")
+29 SET CPTINFO=$$CPT^ICPTCOD(+$GET(CPTS(SDVCPT)),ICPTVDT,1)
+30 if CPTINFO>0
SET X=$PIECE(CPTINFO,"^",2,99)
SET X=$PIECE(X,"^")_" x "_$PIECE($GET(CPTS(SDVCPT)),"^",16)_" "_$PIECE(X,"^",2)
+31 if CPTINFO'>0
SET X="Procedure not defined"
+32 ;
+33 DO SET(SDARY,SDLINE,$EXTRACT(X,1,40),27,"","","","","",.SDTOT)
+34 ;
+35 ;Retrieve Procedure (CPT) Codes and associated Modifiers
+36 SET PTR=0
+37 FOR
SET PTR=+$ORDER(CPTS(SDVCPT,1,PTR))
if 'PTR
QUIT
Begin DoDot:2
+38 SET MODPTR=$GET(CPTS(SDVCPT,1,PTR,0))
+39 if 'MODPTR
QUIT
+40 SET MODINFO=$$MOD^ICPTMOD(MODPTR,"I",ICPTVDT,1)
+41 if MODINFO'>0
QUIT
+42 SET MODCODE="-"_$PIECE(MODINFO,"^",2)
+43 SET MODTEXT=$PIECE(MODINFO,"^",3)
+44 SET SDLINE=SDLINE+1
+45 DO SET(SDARY,SDLINE,MODCODE,29,"","","","","",.SDTOT)
+46 DO SET(SDARY,SDLINE,MODTEXT,38,"","","","","",.SDTOT)
+47 QUIT
End DoDot:2
End DoDot:1
+48 ;
+49 ; -- set indicator that visit was processed
+50 SET SDONE(SDVIEN)=""
AEQ QUIT
+1 ;
SET(SDARY,LINE,TEXT,COL,ON,OFF,SDSUB,SDCNT,SDATA,SDTOT) ; -- set display array
+1 NEW X
+2 if LINE>SDTOT
SET SDTOT=LINE
+3 SET X=$SELECT($DATA(^TMP(SDARY,$JOB,LINE,0)):^(0),1:"")
+4 SET ^TMP(SDARY,$JOB,LINE,0)=$$SETSTR^VALM1(TEXT,X,COL,$LENGTH(TEXT))
+5 if $GET(ON)]""!($GET(OFF)]"")
DO CNTRL^VALM10(LINE,COL,$LENGTH(TEXT),$GET(ON),$GET(OFF))
+6 if $GET(SDSUB)]""
SET ^TMP("SDCOIDX",$JOB,SDSUB,SDCNT,SDLINE)=SDATA
SET ^TMP("SDCOIDX",$JOB,SDSUB,0)=SDCNT
+7 QUIT
DXFTXT(DXTXT,DXARY) ; -- formatted diagnosis text
+1 NEW DIWL,DIWR,X
+2 KILL ^UTILITY($JOB,"W"),DXARY
+3 SET DIWL=1
SET DIWR=26
SET X=$$SENTENCE^XLFSTR(DXTXT)
+4 DO ^DIWP
+5 SET X=""
+6 FOR
SET X=$ORDER(^UTILITY($JOB,"W",1,X))
if X=""
QUIT
Begin DoDot:1
+7 SET DXARY(X)=$GET(^UTILITY($JOB,"W",1,X,0))
End DoDot:1
+8 KILL ^UTILITY($JOB,"W")
+9 QUIT
