SCRPW24 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ;06/19/99
;;5.3;Scheduling;**144,163,180,254,243,295,329,351,510,530,562,576,593**;AUG 13, 1993;Build 13
;06/19/99 ACS - Added CPT modifier API calls
;11/26/03 RLC - 329 fixes primary/secondary dx problem with report
;
APAC(SDX) ;Get all procedure codes
D APAC^SCRPW241(.SDX)
D NX Q
;
APOTR ;Transform procedure external value
D APOTR^SCRPW241(.SDX)
Q
;
APAP(SDX) ;Get ambulatory procedures (no E&M codes)
D APAP^SCRPW241(.SDX)
D NX Q
;
APEM(SDX) ;Get evaluation and management codes
D APEM^SCRPW241(.SDX)
D NX Q
;
CLCG(SDX) ;Get clinic group
K SDX S SDX=$P(SDOE0,U,4) I SDX S SDX=$P($G(^SC(SDX,0)),U,31) I SDX,$D(^SD(409.67,SDX)) S SDX=SDX_U_$P(^SD(409.67,SDX,0),U) S:$L($P(SDX,U,2)) SDX(1)=SDX
D NX Q
;
CLCN(SDX) ;Get clinic name
K SDX S SDX=$P(SDOE0,U,4) I SDX S SDX=SDX_U_$P($G(^SC(SDX,0)),U) I $L($P(SDX,U,2)) S SDX(1)=SDX
D NX Q
;
CLCS(SDX) ;Get clinic service
K SDX S SDX=$P(SDOE0,U,4) I SDX S SDX=$P($G(^SC(SDX,0)),U,8) D FST(.SDX,44,9) S:$L($P(SDX,U,2)) SDX(1)=SDX
D NX Q
;
DXAD(SDX) ;Get all diagnoses
K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0
F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U) I SDX S SDX=SDX_U_$P($$ICDDX^SCRPWICD(+SDX,+SDOE0),U,2) I $L($P(SDX,U,2)) D DXOTR S SDX(SDI)=SDX
D NX Q
;
DXOTR ;Transform diagnosis external value
N ENCDT
S ENCDT=+$G(SDOE0)
I 'ENCDT D
.I '$G(SDOE) S ENCDT=$$NOW^XLFDT() Q
.N SDY
.D GETGEN^SDOE(SDOE,"SDY")
.S ENCDT=+$G(SDY(0))
.K SDY
S SDX=SDX_" "_$P($$ICDDX^SCRPWICD(+SDX,ENCDT),U,4) Q
;
DXGS(SDX,SDZ) ;Get GAF score
K SDX N SDI,SDY S SDY=$S(SDZ="H":$P($P(SDOE0,U),"."),1:DT)_.9999,SDY=9999999-SDY,SDY=$O(^YSD(627.8,"AX5",$P(SDOE0,U,2),SDY))
I SDY S SDI=$O(^YSD(627.8,"AX5",$P(SDOE0,U,2),SDY,""),-1) I SDI S SDX=+$P($G(^YSD(627.8,SDI,60)),U,3) I SDX S SDX(1)=SDX_U_SDX
D NX Q
;
DXGSQ(SDI) ;Set up GAF help text
S SDIRQ("?",1)="Specify a value representing the Global Assessment of Functioning (GAF) score."
I SDI="H" S SDIRQ("?")="Status as of the encounter date/time is used to determine 'historical' values."
I SDI="C" S SDIRQ("?")="Status as of the report run date is used to determine 'current' values."
Q
;
DXPD(SDX) ;Get primary diagnosis
;SD*5.3*329 fixes problem of report not working for primary dx
K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0
F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U) I SDX,$P(SDY(SDI),U,12)="P" S SDX=SDX_U_$P($$ICDDX^SCRPWICD(+SDX,+SDOE0),U,2) I $L($P(SDX,U,2)) D DXOTR S SDX(SDI)=SDX
D NX Q
;
DXSD(SDX) ;Get secondary diagnoses
;SD*5.3*329 fixes problem of report not working for secondary dx
K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0
F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U) I SDX,$P(SDY(SDI),U,12)'="P" S SDX=SDX_U_$P($$ICDDX^SCRPWICD(+SDX,+SDOE0),U,2) I $L($P(SDX,U,2)) D DXOTR S SDX(SDI)=SDX
D NX Q
;
ENED(SDX,SDZ) ;Get enrollment date
K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S (SDX,Y)=$P(SDY,U) X ^DD("DD") S SDX(1)=SDX_U_Y
D NX Q
;
ENEF(SDX,SDZ) ;Get enrollment effective date
K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S (SDX,Y)=$P(SDY,U,8) X ^DD("DD") S SDX(1)=SDX_U_Y
D NX Q
;
ENEP(SDX,SDZ) ;Get enrollment priority
K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,7) D FST(.SDX,27.11,.07) S:$L($P(SDX,U,2)) SDX(1)=SDX
D NX Q
;
ENES(SDX,SDZ) ;Get enrollment status
K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,4),SDX=SDX_U_$$EXTERNAL^DILFD(27.11,.04,"F",SDX) S:$L($P(SDX,U,2)) SDX(1)=SDX
D NX Q
;
ENFR(SDX,SDZ) ;Get enrollment facility received
K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,6) I SDX S SDX=SDX_U_$P($G(^DIC(4,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX
D NX Q
;
ENSE(SDX,SDZ) ;Get enrollment source of enrollment
K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,3) D FST(.SDX,27.11,.03) S:$L($P(SDX,U,2)) SDX(1)=SDX
D NX Q
;
ENQ(SDZ) ;Set up help text for enrollment
I SDZ="H" S SDIRQ("?")="Enrollment status as of the encounter date/time is used for 'historical' values."
I SDZ="C" S SDIRQ("?")="Enrollment status as of the report run date is used for 'current' values."
Q
;
OEAT(SDX) ;Get encounter appointment type
K SDX S SDX=$P(SDOE0,U,10) I SDX S SDX=SDX_U_$P($G(^SD(409.1,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX
D NX Q
;
OEDV(SDX) ;Get encounter division
K SDX S SDX=$P(SDOE0,U,11) I SDX S SDX=SDX_U_$P($G(^DG(40.8,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX
D NX Q
;
OEEE(SDX) ;Get encounter eligibility
K SDX S SDX=$P(SDOE0,U,13) I SDX S SDX=SDX_U_$P($G(^DIC(8,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX
D NX Q
;
OEOP(SDX) ;Get encounter originating process type
K SDX S SDX=$P(SDOE0,U,8) D FST(.SDX,409.68,.08) S:$L($P(SDX,U,2)) SDX(1)=SDX
D NX Q
;
OEPA(SDX) ;Get encounter patient
K SDX S DFN=$P(SDOE0,U,2) I DFN D DEM^VADPT I $L(VADM(1)) S SDX(1)=DFN_U_VADM(1)
D NX Q
;
OEES(SDX) ;Get encounter status
K SDX S SDX=$P(SDOE0,U,12) I SDX S SDX=SDX_U_$P($G(^SD(409.63,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX
D NX Q
;
OETS(SDX) ;Get transmission status
K SDX S SDX(1)=$$STX^SCRPW8(SDOE,SDOE0) Q
;
TSQ(DIR) ;Set up DIR array for transmission status question
K DIR S DIR("A")="Select transmission status",DIR("?")="This value represents the transmission status of the encounter record."
S DIR(0)="SO^0:Not checked-out;1:No transmission record;2:Not required, not transmitted;3:Rejected for transmission;4:Awaiting transmission;5:Transmitted, no acknowledgment;6:Transmitted, rejected;7:Transmitted, error;8:Transmitted, accepted"
Q
;
CLQ(DIR,SDZ) ;Set up DIR array for classification questions
K DIR S SDZ=$S(SDZ="A":"Agent Orange exposure",SDZ="I":"ionizing radiation exposure",SDZ="S":"service connected condition",1:"environmental contaminants exposure")
S DIR(0)="SO^1:YES;0:NO",DIR("A")="Treatment related to "_SDZ,DIR("?")="Indicates if treatment was related to "_SDZ Q
;
OECL(SDX,SDZ) ;Get classification values
K SDX N SDY S SDZ=$S(SDZ="A":1,SDZ="I":2,SDZ="S":3,SDZ="E":4,1:"") I SDZ D CLASK^SDCO2(SDOE,.SDY) S SDX=$P($G(SDY(SDZ)),U,2) I $L(SDX) S SDX(1)=$S(SDX=1:"1^YES",1:"0^NO")
D NX Q
;
OEOU(SDX) ;Get option used to create
K SDX S SDX=+$P(SDOE0,U,5),SDX=+$P($G(^AUPNVSIT(SDX,0)),U,24)
N SDY D GETS^DIQ(19,SDX,.01,"","SDY")
I 'SDX S SDX="0^UNKNOWN",SDX(1)=SDX ;SD*576
I +SDX S SDX=SDX_U_SDY(19,SDX_",",.01) S:$L($P(SDX,U,2)) SDX(1)=SDX
D NX Q
;
SUQ(DIR) ;Set up DIR() array for Scheduled/unscheduled question
K DIR S DIR("A")="Select outpatient activity type",DIR("?",1)="Only pre-scheduled appointments will be reflected as SCHEDULED. All other",DIR("?",2)="types of activity (add/edits, registrations, walkins or unscheduled activity)"
S DIR("?")="will be reflected as UNSCHEDULED.",DIR(0)="SO^S:SCHEDULED;U:UNSCHEDULED" Q
;
OESU(SDX) ;Get scheduled/unscheduled status
N SDAP0 K SDX S SDX(1)=""
I $P(SDOE0,U,8)=1 D Q:$L(SDX(1))
.S SDAP0=$G(^DPT(+$P(SDOE0,U,2),"S",+SDOE0,0))
.Q:$P(SDAP0,U,20)'=SDOE Q:$P(SDAP0,U,7)=4
.S SDX(1)="S^SCHEDULED" Q
S SDX(1)="U^UNSCHEDULED" Q
;
PCPR(SDX,SDZ) ;Get primary care provider
;Required input: SDZ="C" for current, "H" for historical
K SDX S SDX=$S(SDZ="C":$$OUTPTPR^SDUTL3(+$P(SDOE0,U,2)),1:$$OUTPTPR^SDUTL3(+$P(SDOE0,U,2),+$P(SDOE0,U))) S:$L($P(SDX,U,2)) SDX(1)=SDX
D NX Q
;
PCTM(SDX,SDZ) ;Get priamry care team
;Required input: SDZ="C" for current, "H" for historical
K SDX S SDX=$S(SDZ="C":$$OUTPTTM^SDUTL3(+$P(SDOE0,U,2)),1:$$OUTPTTM^SDUTL3(+$P(SDOE0,U,2),+$P(SDOE0,U))) S:$L($P(SDX,U,2)) SDX(1)=SDX
D NX Q
;
PDPA(SDX) ;Get patient age
K SDX S DFN=$P(SDOE0,U,2) I DFN D DEM^VADPT I VADM(4)=+VADM(4) S SDX(1)=VADM(4)_U_VADM(4)
D NX Q
;
PDPS(SDX) ;Get patient sex
K SDX S DFN=$P(SDOE0,U,2) I DFN D DEM^VADPT I $L($P(VADM(5),U,2)) S SDX(1)=VADM(5)
D NX Q
;
PDSC(SDX) ;Get patient state/county
K SDX S DFN=$P(SDOE0,U,2) I DFN D ADD^VADPT I $L($P(VAPA(7),U,2)) S SDX(1)=$P(VAPA(5),U)_";"_$P(VAPA(7),U)_U_$P(VAPA(5),U,2)_" / "_$P(VAPA(7),U,2)
D NX Q
;
PDZC(SDX) ;Get patient zip code
K SDX S DFN=$P(SDOE0,U,2) I DFN D ADD^VADPT I $L(VAPA(6)) S SDX(1)=VAPA(6)_U_VAPA(6)
D NX Q
;
ENROL(SDATE) ;Get enrollment record (most recent to encounter date)
;SD/530 changed For loop and added check for zero node to eliminate undefined error
N SDY,SDI,X1,X2,X,%Y
S:SDATE#1=0 SDATE=SDATE+.9999 S SDI=0 F S SDI=$O(^DGEN(27.11,"C",+$P(SDOE0,U,2),SDI)) Q:'SDI D
.Q:'$D(^DGEN(27.11,SDI,0))
.I '$D(^DGEN(27.11,SDI,"U")) S SDY=$G(^DGEN(27.11,SDI,0)),SDY(+SDY)=SDY Q ;SD*562
.S SDY=$G(^DGEN(27.11,SDI,0)),SDY($P($P(^DGEN(27.11,SDI,"U"),U,1),".",1))=SDY ;SD/510 changed logic to use date/time entered
S SDI=$O(SDY(SDATE),-1) Q:'SDI "" S X1=$P($P(SDOE0,U),"."),X2=SDI D ^%DTC Q SDY(SDI)
;
NX S:$D(SDX)<10 SDX(1)="~~~NONE~~~^~~~NONE~~~" Q
;
FST(SDX,SDFI,SDFE) ;Field set transform
Q:'$L(SDX) N SDY,SDI D FIELD^DID(SDFI,SDFE,"","POINTER","SDY") S SDY=SDY("POINTER") F SDI=1:1:$L(SDY,";") I SDX=$P($P(SDY,";",SDI),":") S SDX=SDX_U_$P($P(SDY,";",SDI),":",2) Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPW24 9178 printed Apr 09, 2024@21:41:30 Page 2
SCRPW24 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ;06/19/99
+1 ;;5.3;Scheduling;**144,163,180,254,243,295,329,351,510,530,562,576,593**;AUG 13, 1993;Build 13
+2 ;06/19/99 ACS - Added CPT modifier API calls
+3 ;11/26/03 RLC - 329 fixes primary/secondary dx problem with report
+4 ;
APAC(SDX) ;Get all procedure codes
+1 DO APAC^SCRPW241(.SDX)
+2 DO NX
QUIT
+3 ;
APOTR ;Transform procedure external value
+1 DO APOTR^SCRPW241(.SDX)
+2 QUIT
+3 ;
APAP(SDX) ;Get ambulatory procedures (no E&M codes)
+1 DO APAP^SCRPW241(.SDX)
+2 DO NX
QUIT
+3 ;
APEM(SDX) ;Get evaluation and management codes
+1 DO APEM^SCRPW241(.SDX)
+2 DO NX
QUIT
+3 ;
CLCG(SDX) ;Get clinic group
+1 KILL SDX
SET SDX=$PIECE(SDOE0,U,4)
IF SDX
SET SDX=$PIECE($GET(^SC(SDX,0)),U,31)
IF SDX
IF $DATA(^SD(409.67,SDX))
SET SDX=SDX_U_$PIECE(^SD(409.67,SDX,0),U)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(1)=SDX
+2 DO NX
QUIT
+3 ;
CLCN(SDX) ;Get clinic name
+1 KILL SDX
SET SDX=$PIECE(SDOE0,U,4)
IF SDX
SET SDX=SDX_U_$PIECE($GET(^SC(SDX,0)),U)
IF $LENGTH($PIECE(SDX,U,2))
SET SDX(1)=SDX
+2 DO NX
QUIT
+3 ;
CLCS(SDX) ;Get clinic service
+1 KILL SDX
SET SDX=$PIECE(SDOE0,U,4)
IF SDX
SET SDX=$PIECE($GET(^SC(SDX,0)),U,8)
DO FST(.SDX,44,9)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(1)=SDX
+2 DO NX
QUIT
+3 ;
DXAD(SDX) ;Get all diagnoses
+1 KILL SDX
NEW SDY,SDI
DO GETDX^SDOE(SDOE,"SDY")
SET SDI=0
+2 FOR
SET SDI=$ORDER(SDY(SDI))
if 'SDI
QUIT
SET SDX=$PIECE(SDY(SDI),U)
IF SDX
SET SDX=SDX_U_$PIECE($$ICDDX^SCRPWICD(+SDX,+SDOE0),U,2)
IF $LENGTH($PIECE(SDX,U,2))
DO DXOTR
SET SDX(SDI)=SDX
+3 DO NX
QUIT
+4 ;
DXOTR ;Transform diagnosis external value
+1 NEW ENCDT
+2 SET ENCDT=+$GET(SDOE0)
+3 IF 'ENCDT
Begin DoDot:1
+4 IF '$GET(SDOE)
SET ENCDT=$$NOW^XLFDT()
QUIT
+5 NEW SDY
+6 DO GETGEN^SDOE(SDOE,"SDY")
+7 SET ENCDT=+$GET(SDY(0))
+8 KILL SDY
End DoDot:1
+9 SET SDX=SDX_" "_$PIECE($$ICDDX^SCRPWICD(+SDX,ENCDT),U,4)
QUIT
+10 ;
DXGS(SDX,SDZ) ;Get GAF score
+1 KILL SDX
NEW SDI,SDY
SET SDY=$SELECT(SDZ="H":$PIECE($PIECE(SDOE0,U),"."),1:DT)_.9999
SET SDY=9999999-SDY
SET SDY=$ORDER(^YSD(627.8,"AX5",$PIECE(SDOE0,U,2),SDY))
+2 IF SDY
SET SDI=$ORDER(^YSD(627.8,"AX5",$PIECE(SDOE0,U,2),SDY,""),-1)
IF SDI
SET SDX=+$PIECE($GET(^YSD(627.8,SDI,60)),U,3)
IF SDX
SET SDX(1)=SDX_U_SDX
+3 DO NX
QUIT
+4 ;
DXGSQ(SDI) ;Set up GAF help text
+1 SET SDIRQ("?",1)="Specify a value representing the Global Assessment of Functioning (GAF) score."
+2 IF SDI="H"
SET SDIRQ("?")="Status as of the encounter date/time is used to determine 'historical' values."
+3 IF SDI="C"
SET SDIRQ("?")="Status as of the report run date is used to determine 'current' values."
+4 QUIT
+5 ;
DXPD(SDX) ;Get primary diagnosis
+1 ;SD*5.3*329 fixes problem of report not working for primary dx
+2 KILL SDX
NEW SDY,SDI
DO GETDX^SDOE(SDOE,"SDY")
SET SDI=0
+3 FOR
SET SDI=$ORDER(SDY(SDI))
if 'SDI
QUIT
SET SDX=$PIECE(SDY(SDI),U)
IF SDX
IF $PIECE(SDY(SDI),U,12)="P"
SET SDX=SDX_U_$PIECE($$ICDDX^SCRPWICD(+SDX,+SDOE0),U,2)
IF $LENGTH($PIECE(SDX,U,2))
DO DXOTR
SET SDX(SDI)=SDX
+4 DO NX
QUIT
+5 ;
DXSD(SDX) ;Get secondary diagnoses
+1 ;SD*5.3*329 fixes problem of report not working for secondary dx
+2 KILL SDX
NEW SDY,SDI
DO GETDX^SDOE(SDOE,"SDY")
SET SDI=0
+3 FOR
SET SDI=$ORDER(SDY(SDI))
if 'SDI
QUIT
SET SDX=$PIECE(SDY(SDI),U)
IF SDX
IF $PIECE(SDY(SDI),U,12)'="P"
SET SDX=SDX_U_$PIECE($$ICDDX^SCRPWICD(+SDX,+SDOE0),U,2)
IF $LENGTH($PIECE(SDX,U,2))
DO DXOTR
SET SDX(SDI)=SDX
+4 DO NX
QUIT
+5 ;
ENED(SDX,SDZ) ;Get enrollment date
+1 KILL SDX
NEW SDY
SET SDY=$$ENROL($SELECT(SDZ="H":+SDOE0,1:DT))
IF SDY
SET (SDX,Y)=$PIECE(SDY,U)
XECUTE ^DD("DD")
SET SDX(1)=SDX_U_Y
+2 DO NX
QUIT
+3 ;
ENEF(SDX,SDZ) ;Get enrollment effective date
+1 KILL SDX
NEW SDY
SET SDY=$$ENROL($SELECT(SDZ="H":+SDOE0,1:DT))
IF SDY
SET (SDX,Y)=$PIECE(SDY,U,8)
XECUTE ^DD("DD")
SET SDX(1)=SDX_U_Y
+2 DO NX
QUIT
+3 ;
ENEP(SDX,SDZ) ;Get enrollment priority
+1 KILL SDX
NEW SDY
SET SDY=$$ENROL($SELECT(SDZ="H":+SDOE0,1:DT))
IF SDY
SET SDX=$PIECE(SDY,U,7)
DO FST(.SDX,27.11,.07)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(1)=SDX
+2 DO NX
QUIT
+3 ;
ENES(SDX,SDZ) ;Get enrollment status
+1 KILL SDX
NEW SDY
SET SDY=$$ENROL($SELECT(SDZ="H":+SDOE0,1:DT))
IF SDY
SET SDX=$PIECE(SDY,U,4)
SET SDX=SDX_U_$$EXTERNAL^DILFD(27.11,.04,"F",SDX)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(1)=SDX
+2 DO NX
QUIT
+3 ;
ENFR(SDX,SDZ) ;Get enrollment facility received
+1 KILL SDX
NEW SDY
SET SDY=$$ENROL($SELECT(SDZ="H":+SDOE0,1:DT))
IF SDY
SET SDX=$PIECE(SDY,U,6)
IF SDX
SET SDX=SDX_U_$PIECE($GET(^DIC(4,SDX,0)),U)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(1)=SDX
+2 DO NX
QUIT
+3 ;
ENSE(SDX,SDZ) ;Get enrollment source of enrollment
+1 KILL SDX
NEW SDY
SET SDY=$$ENROL($SELECT(SDZ="H":+SDOE0,1:DT))
IF SDY
SET SDX=$PIECE(SDY,U,3)
DO FST(.SDX,27.11,.03)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(1)=SDX
+2 DO NX
QUIT
+3 ;
ENQ(SDZ) ;Set up help text for enrollment
+1 IF SDZ="H"
SET SDIRQ("?")="Enrollment status as of the encounter date/time is used for 'historical' values."
+2 IF SDZ="C"
SET SDIRQ("?")="Enrollment status as of the report run date is used for 'current' values."
+3 QUIT
+4 ;
OEAT(SDX) ;Get encounter appointment type
+1 KILL SDX
SET SDX=$PIECE(SDOE0,U,10)
IF SDX
SET SDX=SDX_U_$PIECE($GET(^SD(409.1,SDX,0)),U)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(1)=SDX
+2 DO NX
QUIT
+3 ;
OEDV(SDX) ;Get encounter division
+1 KILL SDX
SET SDX=$PIECE(SDOE0,U,11)
IF SDX
SET SDX=SDX_U_$PIECE($GET(^DG(40.8,SDX,0)),U)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(1)=SDX
+2 DO NX
QUIT
+3 ;
OEEE(SDX) ;Get encounter eligibility
+1 KILL SDX
SET SDX=$PIECE(SDOE0,U,13)
IF SDX
SET SDX=SDX_U_$PIECE($GET(^DIC(8,SDX,0)),U)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(1)=SDX
+2 DO NX
QUIT
+3 ;
OEOP(SDX) ;Get encounter originating process type
+1 KILL SDX
SET SDX=$PIECE(SDOE0,U,8)
DO FST(.SDX,409.68,.08)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(1)=SDX
+2 DO NX
QUIT
+3 ;
OEPA(SDX) ;Get encounter patient
+1 KILL SDX
SET DFN=$PIECE(SDOE0,U,2)
IF DFN
DO DEM^VADPT
IF $LENGTH(VADM(1))
SET SDX(1)=DFN_U_VADM(1)
+2 DO NX
QUIT
+3 ;
OEES(SDX) ;Get encounter status
+1 KILL SDX
SET SDX=$PIECE(SDOE0,U,12)
IF SDX
SET SDX=SDX_U_$PIECE($GET(^SD(409.63,SDX,0)),U)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(1)=SDX
+2 DO NX
QUIT
+3 ;
OETS(SDX) ;Get transmission status
+1 KILL SDX
SET SDX(1)=$$STX^SCRPW8(SDOE,SDOE0)
QUIT
+2 ;
TSQ(DIR) ;Set up DIR array for transmission status question
+1 KILL DIR
SET DIR("A")="Select transmission status"
SET DIR("?")="This value represents the transmission status of the encounter record."
+2 SET DIR(0)="SO^0:Not checked-out;1:No transmission record;2:Not required, not transmitted;3:Rejected for transmission;4:Awaiting transmission;5:Transmitted, no acknowledgment;6:Transmitted, rejected;7:Transmitted, error;8:Transmitted, accepted"
+3 QUIT
+4 ;
CLQ(DIR,SDZ) ;Set up DIR array for classification questions
+1 KILL DIR
SET SDZ=$SELECT(SDZ="A":"Agent Orange exposure",SDZ="I":"ionizing radiation exposure",SDZ="S":"service connected condition",1:"environmental contaminants exposure")
+2 SET DIR(0)="SO^1:YES;0:NO"
SET DIR("A")="Treatment related to "_SDZ
SET DIR("?")="Indicates if treatment was related to "_SDZ
QUIT
+3 ;
OECL(SDX,SDZ) ;Get classification values
+1 KILL SDX
NEW SDY
SET SDZ=$SELECT(SDZ="A":1,SDZ="I":2,SDZ="S":3,SDZ="E":4,1:"")
IF SDZ
DO CLASK^SDCO2(SDOE,.SDY)
SET SDX=$PIECE($GET(SDY(SDZ)),U,2)
IF $LENGTH(SDX)
SET SDX(1)=$SELECT(SDX=1:"1^YES",1:"0^NO")
+2 DO NX
QUIT
+3 ;
OEOU(SDX) ;Get option used to create
+1 KILL SDX
SET SDX=+$PIECE(SDOE0,U,5)
SET SDX=+$PIECE($GET(^AUPNVSIT(SDX,0)),U,24)
+2 NEW SDY
DO GETS^DIQ(19,SDX,.01,"","SDY")
+3 ;SD*576
IF 'SDX
SET SDX="0^UNKNOWN"
SET SDX(1)=SDX
+4 IF +SDX
SET SDX=SDX_U_SDY(19,SDX_",",.01)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(1)=SDX
+5 DO NX
QUIT
+6 ;
SUQ(DIR) ;Set up DIR() array for Scheduled/unscheduled question
+1 KILL DIR
SET DIR("A")="Select outpatient activity type"
SET DIR("?",1)="Only pre-scheduled appointments will be reflected as SCHEDULED. All other"
SET DIR("?",2)="types of activity (add/edits, registrations, walkins or unscheduled activity)"
+2 SET DIR("?")="will be reflected as UNSCHEDULED."
SET DIR(0)="SO^S:SCHEDULED;U:UNSCHEDULED"
QUIT
+3 ;
OESU(SDX) ;Get scheduled/unscheduled status
+1 NEW SDAP0
KILL SDX
SET SDX(1)=""
+2 IF $PIECE(SDOE0,U,8)=1
Begin DoDot:1
+3 SET SDAP0=$GET(^DPT(+$PIECE(SDOE0,U,2),"S",+SDOE0,0))
+4 if $PIECE(SDAP0,U,20)'=SDOE
QUIT
if $PIECE(SDAP0,U,7)=4
QUIT
+5 SET SDX(1)="S^SCHEDULED"
QUIT
End DoDot:1
if $LENGTH(SDX(1))
QUIT
+6 SET SDX(1)="U^UNSCHEDULED"
QUIT
+7 ;
PCPR(SDX,SDZ) ;Get primary care provider
+1 ;Required input: SDZ="C" for current, "H" for historical
+2 KILL SDX
SET SDX=$SELECT(SDZ="C":$$OUTPTPR^SDUTL3(+$PIECE(SDOE0,U,2)),1:$$OUTPTPR^SDUTL3(+$PIECE(SDOE0,U,2),+$PIECE(SDOE0,U)))
if $LENGTH($PIECE(SDX,U,2))
SET SDX(1)=SDX
+3 DO NX
QUIT
+4 ;
PCTM(SDX,SDZ) ;Get priamry care team
+1 ;Required input: SDZ="C" for current, "H" for historical
+2 KILL SDX
SET SDX=$SELECT(SDZ="C":$$OUTPTTM^SDUTL3(+$PIECE(SDOE0,U,2)),1:$$OUTPTTM^SDUTL3(+$PIECE(SDOE0,U,2),+$PIECE(SDOE0,U)))
if $LENGTH($PIECE(SDX,U,2))
SET SDX(1)=SDX
+3 DO NX
QUIT
+4 ;
PDPA(SDX) ;Get patient age
+1 KILL SDX
SET DFN=$PIECE(SDOE0,U,2)
IF DFN
DO DEM^VADPT
IF VADM(4)=+VADM(4)
SET SDX(1)=VADM(4)_U_VADM(4)
+2 DO NX
QUIT
+3 ;
PDPS(SDX) ;Get patient sex
+1 KILL SDX
SET DFN=$PIECE(SDOE0,U,2)
IF DFN
DO DEM^VADPT
IF $LENGTH($PIECE(VADM(5),U,2))
SET SDX(1)=VADM(5)
+2 DO NX
QUIT
+3 ;
PDSC(SDX) ;Get patient state/county
+1 KILL SDX
SET DFN=$PIECE(SDOE0,U,2)
IF DFN
DO ADD^VADPT
IF $LENGTH($PIECE(VAPA(7),U,2))
SET SDX(1)=$PIECE(VAPA(5),U)_";"_$PIECE(VAPA(7),U)_U_$PIECE(VAPA(5),U,2)_" / "_$PIECE(VAPA(7),U,2)
+2 DO NX
QUIT
+3 ;
PDZC(SDX) ;Get patient zip code
+1 KILL SDX
SET DFN=$PIECE(SDOE0,U,2)
IF DFN
DO ADD^VADPT
IF $LENGTH(VAPA(6))
SET SDX(1)=VAPA(6)_U_VAPA(6)
+2 DO NX
QUIT
+3 ;
ENROL(SDATE) ;Get enrollment record (most recent to encounter date)
+1 ;SD/530 changed For loop and added check for zero node to eliminate undefined error
+2 NEW SDY,SDI,X1,X2,X,%Y
+3 if SDATE#1=0
SET SDATE=SDATE+.9999
SET SDI=0
FOR
SET SDI=$ORDER(^DGEN(27.11,"C",+$PIECE(SDOE0,U,2),SDI))
if 'SDI
QUIT
Begin DoDot:1
+4 if '$DATA(^DGEN(27.11,SDI,0))
QUIT
+5 ;SD*562
IF '$DATA(^DGEN(27.11,SDI,"U"))
SET SDY=$GET(^DGEN(27.11,SDI,0))
SET SDY(+SDY)=SDY
QUIT
+6 ;SD/510 changed logic to use date/time entered
SET SDY=$GET(^DGEN(27.11,SDI,0))
SET SDY($PIECE($PIECE(^DGEN(27.11,SDI,"U"),U,1),".",1))=SDY
End DoDot:1
+7 SET SDI=$ORDER(SDY(SDATE),-1)
if 'SDI
QUIT ""
SET X1=$PIECE($PIECE(SDOE0,U),".")
SET X2=SDI
DO ^%DTC
QUIT SDY(SDI)
+8 ;
NX if $DATA(SDX)<10
SET SDX(1)="~~~NONE~~~^~~~NONE~~~"
QUIT
+1 ;
FST(SDX,SDFI,SDFE) ;Field set transform
+1 if '$LENGTH(SDX)
QUIT
NEW SDY,SDI
DO FIELD^DID(SDFI,SDFE,"","POINTER","SDY")
SET SDY=SDY("POINTER")
FOR SDI=1:1:$LENGTH(SDY,";")
IF SDX=$PIECE($PIECE(SDY,";",SDI),":")
SET SDX=SDX_U_$PIECE($PIECE(SDY,";",SDI),":",2)
QUIT
+2 QUIT
