SCRPW25 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ; 12/5/00 4:15pm
;;5.3;Scheduling;**144,177,232**;AUG 13, 1993
PEAO(SDX) ;Get agent orange indicator
K SDX S DFN=$P(SDOE0,U,2) I DFN D SVC^VADPT I $L(VASV(2)) S SDX(1)=VASV(2)_U_$S(VASV(2):"YES",1:"NO")
D NX Q
;
PEEC(SDX) ;Get environmental contaminants indicator
K SDX S SDX=$P($G(^DPT($P(SDOE0,U,2),.322)),U,13) I $L(SDX) D FST(.SDX,2,.322013) I $L($P(SDX,U,2)) S SDX(1)=SDX
D NX Q
;
PEIR(SDX) ;Get ionizing radiation indicator
K SDX S DFN=$P(SDOE0,U,2) I DFN D SVC^VADPT I $L(VASV(3)) S SDX(1)=VASV(3)_U_$S(VASV(3):"YES",1:"NO")
D NX Q
;
PEMT(SDX,SDZ) ;Get patient means test
K SDX N SDY S SDX=$$LST^DGMTU(+$P(SDOE0,U,2),$S(SDZ="H":+$P(SDOE0,U),1:DT)) I $L($P(SDX,U,4)) S SDY=$O(^DG(408.32,"C",$P(SDX,U,4),0)) I SDY S SDX(1)=SDY_U_$P(SDX,U,3)
D NX Q
;
PEMTQ(SDZ) ;Set up means test help text
I SDZ="H" S SDIRQ("?")="Means Test status as of the encounter date/time is used for 'historical' values."
I SDZ="C" S SDIRQ("?")="Means Test status as of the report run date is used for 'current' values."
Q
;
PEPE(SDX) ;Get patient primary eligibility
K SDX S DFN=$P(SDOE0,U,2) I DFN D ELIG^VADPT I $L($P(VAEL(1),U,2)) S SDX(1)=VAEL(1)
D NX Q
;
PEAE(SDX) ;Get all patient eligibilities
K SDX S DFN=$P(SDOE0,U,2) I DFN D ELIG^VADPT M SDX=VAEL(1) I VAEL(1) S SDX(+VAEL(1))=VAEL(1)
D NX Q
;
PEPS(SDX) ;Get patient period of service
K SDX S DFN=$P(SDOE0,U,2) I DFN D ELIG^VADPT I $L($P(VAEL(2),U,2)) S SDX(1)=VAEL(2)
D NX Q
;
PEPW(SDX) ;Get patient POW indicated
K SDX S DFN=$P(SDOE0,U,2) I DFN D SVC^VADPT I $L(VASV(4)) S SDX(1)=VASV(4)_U_$S(VASV(4)=1:"YES",1:"NO")
D NX Q
;
PESP(SDX) ;Get service connected percentage
K SDX S DFN=$P(SDOE0,U,2) I DFN D ELIG^VADPT I VAEL(3) S SDX(1)=+$P(VAEL(3),U,2)_U_+$P(VAEL(3),U,2)
D NX Q
;
PEVT(SDX) ;Get veteran (y/n)?
K SDX S DFN=$P(SDOE0,U,2) I DFN D ELIG^VADPT I $L(VAEL(4)) S SDX(1)=$S(VAEL(4)=1:"Y^YES",1:"N^NO")
D NX Q
;
PRAP(SDX) ;Get all providers
K SDX N SDY,SDI D GETPRV^SDOE(SDOE,"SDY") S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U),SDX=SDX_U_$P($G(^VA(200,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(SDI)=SDX
D NX Q
;
PRPC(SDX,SDP) ;Get person class
K SDX N SDY,SDI D GETPRV^SDOE(SDOE,"SDY") S SDI=0
F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U,4) I $S(SDP="P"&(SDX="P"):1,SDP="S"&(SDX'="P"):1,SDP="A":1,1:0) S SDX=$P(SDY(SDI),U,6) I SDX S SDX=SDX_U_$P($$CODE2TXT^XUA4A72(SDX),U) I $L($P(SDX,U,2)) D PCOTR S SDX(SDI)=SDX Q:SDP="P"
D NX Q
;
PCOTR ;Person class output transform
N SDI,SDII,SDY S SDY=$G(^USC(8932.1,+SDX,0)) F SDI=2,3 S SDII=$P(SDY,U,SDI) S:$L(SDII) SDX=SDX_"/"_SDII
S SDX=$E(SDX,1,42) Q
;
PRPP(SDX) ;Get primary provider
K SDX N SDY,SDI D GETPRV^SDOE(SDOE,"SDY") S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI I $P(SDY(SDI),U,4)="P" S SDX=$P(SDY(SDI),U),SDX=SDX_U_$P($G(^VA(200,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(SDI)=SDX Q
D NX Q
;
PRSP(SDX) ;Get secondary providers
K SDX N SDY,SDI D GETPRV^SDOE(SDOE,"SDY") S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI I $P(SDY(SDI),U,4)'="P" S SDX=$P(SDY(SDI),U),SDX=SDX_U_$P($G(^VA(200,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(SDI)=SDX
D NX Q
;
SCBC(SDX) ;Get both stop codes
K SDX S SDX=$P(SDOE0,U,3) I SDX S SDX=SDX_U_$P($G(^DIC(40.7,SDX,0)),U) I $L($P(SDX,U,2)) D SCOTR S SDX(1)=SDX
N SDI S SDI=0 F S SDI=$O(^SCE("APAR",SDOE,SDI)) Q:'SDI S SDOECH=$$GETOE^SDOE(SDI) I $P(SDOECH,U,8)=4 S SDX=$P(SDOECH,U,3) I SDX S SDX=SDX_U_$P($G(^DIC(40.7,SDX,0)),U) I $L($P(SDX,U,2)) D SCOTR S SDX(2)=SDX
D NX Q
;
SCPC(SDX) ;Get primary stop code
K SDX S SDX=$P(SDOE0,U,3) I SDX S SDX=SDX_U_$P($G(^DIC(40.7,SDX,0)),U) I $L($P(SDX,U,2)) D SCOTR S SDX(1)=SDX
D NX Q
;
SCSC(SDX) ;Get secondary stop code
K SDX N SDI S SDI=0 F S SDI=$O(^SCE("APAR",SDOE,SDI)) Q:'SDI S SDOECH=$$GETOE^SDOE(SDI) I $P(SDOECH,U,8)=4 S SDX=$P(SDOECH,U,3) I SDX S SDX=SDX_U_$P($G(^DIC(40.7,SDX,0)),U) I $L($P(SDX,U,2)) D SCOTR S SDX(2)=SDX
D NX Q
;
SCOTR ;Transform stop code external value
S $P(SDX,U,2)=$P(^DIC(40.7,+SDX,0),U,2)_" "_$P(SDX,U,2) Q
;
SCCP(SDX) ;Get stop code credit pair
K SDX N SDY D SCBC(.SDY) S SDX=$E($P(SDY(1),U,2),1,3) K:SDX'?3N SDX I $D(SDX) S SDX=SDX_$E($P($G(SDY(2)),U,2),1,3) S:SDX'?6N SDX=$E(SDX,1,3)_"000" D CPOTR S SDX(1)=SDX
D NX Q
;
CPOTR ;Credit pair output transform
N SDSC1,SDSC2,SDZ
S SDSC1=$O(^DIC(40.7,"C",$E(SDX,1,3),"")) Q:'SDSC1 S SDSC1=$P(^DIC(40.7,SDSC1,0),U),SDSC1=$TR(SDSC1,"/","-")
I $E(SDX,4,6)="000" S SDSC2="(NONE)" G CPO1
S SDSC2=$O(^DIC(40.7,"C",$E(SDX,4,6),"")) Q:'SDSC2 S SDSC2=$P(^DIC(40.7,SDSC2,0),U),SDSC2=$TR(SDSC2,"/","-")
CPO1 I $L(SDSC1)<17 S SDZ=SDSC1_"/"_$E(SDSC2,1,(17+(17-$L(SDSC1)))) G CPOTQ
I $L(SDSC2)<17 S SDZ=$E(SDSC1,1,(17+(17-$L(SDSC2))))_"/"_SDSC2 G CPOTQ
S SDZ=$E(SDSC1,1,17)_"/"_$E(SDSC2,1,17)
CPOTQ S $P(SDX,U,2)=$P(SDX,U)_" "_SDZ Q
;
VFEX(SDX) ;Get examinations
K SDX N SDY,SDI S SDY=+$P(SDOE0,U,5),SDI=0 F S SDI=$O(^AUPNVXAM("AD",SDY,SDI)) Q:'SDI S SDX=$P($G(^AUPNVXAM(SDI,0)),U),SDX=SDX_U_$P($G(^AUTTEXAM(+SDX,0)),U) S:$L($P(SDX,U,2)) SDX(SDI)=SDX
D NX Q
;
VFHF(SDX) ;Get health factors
K SDX N SDY,SDI S SDY=+$P(SDOE0,U,5),SDI=0 F S SDI=$O(^AUPNVHF("AD",SDY,SDI)) Q:'SDI S SDX=$P($G(^AUPNVHF(SDI,0)),U),SDX=SDX_U_$P($G(^AUTTHF(+SDX,0)),U) S:$L($P(SDX,U,2)) SDX(SDI)=SDX
D NX Q
;
VFIM(SDX) ;Get immunizations
K SDX N SDY,SDI S SDY=+$P(SDOE0,U,5),SDI=0 F S SDI=$O(^AUPNVIMM("AD",SDY,SDI)) Q:'SDI S SDX=$P($G(^AUPNVIMM(SDI,0)),U),SDX=SDX_U_$P($G(^AUTTIMM(+SDX,0)),U) S:$L($P(SDX,U,2)) SDX(SDI)=SDX
D NX Q
;
VFPE(SDX) ;Get patient education
K SDX N SDY,SDI S SDY=+$P(SDOE0,U,5),SDI=0 F S SDI=$O(^AUPNVPED("AD",SDY,SDI)) Q:'SDI S SDX=$P($G(^AUPNVPED(SDI,0)),U),SDX=SDX_U_$P($G(^AUTTEDT(+SDX,0)),U) S:$L($P(SDX,U,2)) SDX(SDI)=SDX
D NX Q
;
VFST(SDX) ;Get skin tests
K SDX N SDY,SDI S SDY=+$P(SDOE0,U,5),SDI=0 F S SDI=$O(^AUPNVSK("AD",SDY,SDI)) Q:'SDI S SDX=$P($G(^AUPNVSK(SDI,0)),U),SDX=SDX_U_$P($G(^AUTTSK(+SDX,0)),U) S:$L($P(SDX,U,2)) SDX(SDI)=SDX
D NX Q
;
VFTR(SDX) ;Get treatments
K SDX N SDY,SDI S SDY=+$P(SDOE0,U,5),SDI=0 F S SDI=$O(^AUPNVTRT("AD",SDY,SDI)) Q:'SDI S SDX=$P($G(^AUPNVTRT(SDI,0)),U),SDX=SDX_U_$P($G(^AUTTTRT(+SDX,0)),U) S:$L($P(SDX,U,2)) SDX(SDI)=SDX
D NX Q
;
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
;
VETQ(DIR) ;Set up DIR array for 'veteran?' prompt
S DIR(0)="SO^Y:YES;N:NO",DIR("?")="Indicates if the patient served in the U.S. armed forces." Q
;
AOQ(DIR) ;Set up DIR array for agent orange prompt
S DIR(0)="SO^1:YES;0:NO",DIR("?")="Indicates if the patient was exposed to agent orange." Q
;
IRQ(DIR) ;Set up DIR array for ionizing radiation prompt
S DIR(0)="SO^1:YES;0:NO",DIR("?")="Indicates if the patient was exposed to ionizing radiation." Q
;
ECQ(DIR) ;Set up DIR array for environmental contaminants prompt
S DIR(0)="SO^Y:YES;N:NO;U:UNKNOWN",DIR("?")="Indicates if the patient was exposed to environmental contaminants." Q
;
POWQ(DIR) ;Set up DIR array for POW prompt
S DIR(0)="SO^1:YES;0:NO",DIR("?")="Indicates if the patient was a prisoner of war." Q
;
CPQ ;Credit pair help text
S SDIRQ("?",1)="Enter a six digit numeric value that represents two valid stop codes, or a",SDIRQ("?",2)="valid stop code followed by three zeros for clinics that do not have a (second)",SDIRQ("?")="credit stop code."
Q ; SD*5.3*232 TEJ - Q TO PREVENT CPQ OVERRUN INTO PCAP 11/28/00
;
PCAP(SDX,SDZ) ;Get primary care associate provider
;Required input: SDZ="C" for current, "H" for historical
N SDI,SDATE,SDLIST,DFN
D VARZ(SDZ) S SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDLIST)
S SDX=$P($G(^TMP("SDPLIST",$J,DFN,"PCAP",1)),U,1,2)
I $L($P(SDX,U,2)) S SDX(1)=SDX
K ^TMP("SDPLIST",$J,DFN)
D NX Q
;
NPCP(SDX,SDZ) ;Get non-primary care provider information
;Required input: SDZ="C" for current, "H" for historical
N SDI,SDATE,SDLIST,DFN
D VARZ(SDZ) S SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDLIST),SDI=0
F S SDI=$O(^TMP("SDPLIST",$J,DFN,"NPCPR",SDI)) Q:'SDI D
.S SDX=$P($G(^TMP("SDPLIST",$J,DFN,"NPCPR",SDI)),U,1,2)
.I $L($P(SDX,U,2)) S SDX(SDI)=SDX
.Q
K ^TMP("SDPLIST",$J,DFN)
D NX Q
;
NPCT(SDX,SDZ) ;Get non-primary care team information
;Required input: SDZ="C" for current, "H" for historical
N SDI,SDATE,SDLIST,DFN
D VARZ(SDZ) S SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDLIST),SDI=0
F S SDI=$O(^TMP("SDPLIST",$J,DFN,"NPCTM",SDI)) Q:'SDI D
.S SDX=$P($G(^TMP("SDPLIST",$J,DFN,"NPCTM",SDI)),U,1,2)
.I $L($P(SDX,U,2)) S SDX(SDI)=SDX
.Q
K ^TMP("SDPLIST",$J,DFN)
D NX Q
;
VARZ(SDZ) ;Produce variables
;Input: SDZ="C" for current, "H" for historical
S SDLIST="^TMP(""SDPLIST"",$J)",DFN=+$P(SDOE0,U,2) K SDX,@SDLIST
S SDATE=$S(SDZ="C":DT,1:+$P(SDOE0,U))
S (SDATE("BEGIN"),SDATE("END"))=SDATE,SDATE="SDATE"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPW25 9027 printed Dec 13, 2024@02:43:29 Page 2
SCRPW25 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ; 12/5/00 4:15pm
+1 ;;5.3;Scheduling;**144,177,232**;AUG 13, 1993
PEAO(SDX) ;Get agent orange indicator
+1 KILL SDX
SET DFN=$PIECE(SDOE0,U,2)
IF DFN
DO SVC^VADPT
IF $LENGTH(VASV(2))
SET SDX(1)=VASV(2)_U_$SELECT(VASV(2):"YES",1:"NO")
+2 DO NX
QUIT
+3 ;
PEEC(SDX) ;Get environmental contaminants indicator
+1 KILL SDX
SET SDX=$PIECE($GET(^DPT($PIECE(SDOE0,U,2),.322)),U,13)
IF $LENGTH(SDX)
DO FST(.SDX,2,.322013)
IF $LENGTH($PIECE(SDX,U,2))
SET SDX(1)=SDX
+2 DO NX
QUIT
+3 ;
PEIR(SDX) ;Get ionizing radiation indicator
+1 KILL SDX
SET DFN=$PIECE(SDOE0,U,2)
IF DFN
DO SVC^VADPT
IF $LENGTH(VASV(3))
SET SDX(1)=VASV(3)_U_$SELECT(VASV(3):"YES",1:"NO")
+2 DO NX
QUIT
+3 ;
PEMT(SDX,SDZ) ;Get patient means test
+1 KILL SDX
NEW SDY
SET SDX=$$LST^DGMTU(+$PIECE(SDOE0,U,2),$SELECT(SDZ="H":+$PIECE(SDOE0,U),1:DT))
IF $LENGTH($PIECE(SDX,U,4))
SET SDY=$ORDER(^DG(408.32,"C",$PIECE(SDX,U,4),0))
IF SDY
SET SDX(1)=SDY_U_$PIECE(SDX,U,3)
+2 DO NX
QUIT
+3 ;
PEMTQ(SDZ) ;Set up means test help text
+1 IF SDZ="H"
SET SDIRQ("?")="Means Test status as of the encounter date/time is used for 'historical' values."
+2 IF SDZ="C"
SET SDIRQ("?")="Means Test status as of the report run date is used for 'current' values."
+3 QUIT
+4 ;
PEPE(SDX) ;Get patient primary eligibility
+1 KILL SDX
SET DFN=$PIECE(SDOE0,U,2)
IF DFN
DO ELIG^VADPT
IF $LENGTH($PIECE(VAEL(1),U,2))
SET SDX(1)=VAEL(1)
+2 DO NX
QUIT
+3 ;
PEAE(SDX) ;Get all patient eligibilities
+1 KILL SDX
SET DFN=$PIECE(SDOE0,U,2)
IF DFN
DO ELIG^VADPT
MERGE SDX=VAEL(1)
IF VAEL(1)
SET SDX(+VAEL(1))=VAEL(1)
+2 DO NX
QUIT
+3 ;
PEPS(SDX) ;Get patient period of service
+1 KILL SDX
SET DFN=$PIECE(SDOE0,U,2)
IF DFN
DO ELIG^VADPT
IF $LENGTH($PIECE(VAEL(2),U,2))
SET SDX(1)=VAEL(2)
+2 DO NX
QUIT
+3 ;
PEPW(SDX) ;Get patient POW indicated
+1 KILL SDX
SET DFN=$PIECE(SDOE0,U,2)
IF DFN
DO SVC^VADPT
IF $LENGTH(VASV(4))
SET SDX(1)=VASV(4)_U_$SELECT(VASV(4)=1:"YES",1:"NO")
+2 DO NX
QUIT
+3 ;
PESP(SDX) ;Get service connected percentage
+1 KILL SDX
SET DFN=$PIECE(SDOE0,U,2)
IF DFN
DO ELIG^VADPT
IF VAEL(3)
SET SDX(1)=+$PIECE(VAEL(3),U,2)_U_+$PIECE(VAEL(3),U,2)
+2 DO NX
QUIT
+3 ;
PEVT(SDX) ;Get veteran (y/n)?
+1 KILL SDX
SET DFN=$PIECE(SDOE0,U,2)
IF DFN
DO ELIG^VADPT
IF $LENGTH(VAEL(4))
SET SDX(1)=$SELECT(VAEL(4)=1:"Y^YES",1:"N^NO")
+2 DO NX
QUIT
+3 ;
PRAP(SDX) ;Get all providers
+1 KILL SDX
NEW SDY,SDI
DO GETPRV^SDOE(SDOE,"SDY")
SET SDI=0
FOR
SET SDI=$ORDER(SDY(SDI))
if 'SDI
QUIT
SET SDX=$PIECE(SDY(SDI),U)
SET SDX=SDX_U_$PIECE($GET(^VA(200,SDX,0)),U)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(SDI)=SDX
+2 DO NX
QUIT
+3 ;
PRPC(SDX,SDP) ;Get person class
+1 KILL SDX
NEW SDY,SDI
DO GETPRV^SDOE(SDOE,"SDY")
SET SDI=0
+2 FOR
SET SDI=$ORDER(SDY(SDI))
if 'SDI
QUIT
SET SDX=$PIECE(SDY(SDI),U,4)
IF $SELECT(SDP="P"&(SDX="P"):1,SDP="S"&(SDX'="P"):1,SDP="A":1,1:0)
SET SDX=$PIECE(SDY(SDI),U,6)
IF SDX
SET SDX=SDX_U_$PIECE($$CODE2TXT^XUA4A72(SDX),U)
IF $LENGTH($PIECE(SDX,U,2))
DO PCOTR
SET SDX(SDI)=SDX
if SDP="P"
QUIT
+3 DO NX
QUIT
+4 ;
PCOTR ;Person class output transform
+1 NEW SDI,SDII,SDY
SET SDY=$GET(^USC(8932.1,+SDX,0))
FOR SDI=2,3
SET SDII=$PIECE(SDY,U,SDI)
if $LENGTH(SDII)
SET SDX=SDX_"/"_SDII
+2 SET SDX=$EXTRACT(SDX,1,42)
QUIT
+3 ;
PRPP(SDX) ;Get primary provider
+1 KILL SDX
NEW SDY,SDI
DO GETPRV^SDOE(SDOE,"SDY")
SET SDI=0
FOR
SET SDI=$ORDER(SDY(SDI))
if 'SDI
QUIT
IF $PIECE(SDY(SDI),U,4)="P"
SET SDX=$PIECE(SDY(SDI),U)
SET SDX=SDX_U_$PIECE($GET(^VA(200,SDX,0)),U)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(SDI)=SDX
QUIT
+2 DO NX
QUIT
+3 ;
PRSP(SDX) ;Get secondary providers
+1 KILL SDX
NEW SDY,SDI
DO GETPRV^SDOE(SDOE,"SDY")
SET SDI=0
FOR
SET SDI=$ORDER(SDY(SDI))
if 'SDI
QUIT
IF $PIECE(SDY(SDI),U,4)'="P"
SET SDX=$PIECE(SDY(SDI),U)
SET SDX=SDX_U_$PIECE($GET(^VA(200,SDX,0)),U)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(SDI)=SDX
+2 DO NX
QUIT
+3 ;
SCBC(SDX) ;Get both stop codes
+1 KILL SDX
SET SDX=$PIECE(SDOE0,U,3)
IF SDX
SET SDX=SDX_U_$PIECE($GET(^DIC(40.7,SDX,0)),U)
IF $LENGTH($PIECE(SDX,U,2))
DO SCOTR
SET SDX(1)=SDX
+2 NEW SDI
SET SDI=0
FOR
SET SDI=$ORDER(^SCE("APAR",SDOE,SDI))
if 'SDI
QUIT
SET SDOECH=$$GETOE^SDOE(SDI)
IF $PIECE(SDOECH,U,8)=4
SET SDX=$PIECE(SDOECH,U,3)
IF SDX
SET SDX=SDX_U_$PIECE($GET(^DIC(40.7,SDX,0)),U)
IF $LENGTH($PIECE(SDX,U,2))
DO SCOTR
SET SDX(2)=SDX
+3 DO NX
QUIT
+4 ;
SCPC(SDX) ;Get primary stop code
+1 KILL SDX
SET SDX=$PIECE(SDOE0,U,3)
IF SDX
SET SDX=SDX_U_$PIECE($GET(^DIC(40.7,SDX,0)),U)
IF $LENGTH($PIECE(SDX,U,2))
DO SCOTR
SET SDX(1)=SDX
+2 DO NX
QUIT
+3 ;
SCSC(SDX) ;Get secondary stop code
+1 KILL SDX
NEW SDI
SET SDI=0
FOR
SET SDI=$ORDER(^SCE("APAR",SDOE,SDI))
if 'SDI
QUIT
SET SDOECH=$$GETOE^SDOE(SDI)
IF $PIECE(SDOECH,U,8)=4
SET SDX=$PIECE(SDOECH,U,3)
IF SDX
SET SDX=SDX_U_$PIECE($GET(^DIC(40.7,SDX,0)),U)
IF $LENGTH($PIECE(SDX,U,2))
DO SCOTR
SET SDX(2)=SDX
+2 DO NX
QUIT
+3 ;
SCOTR ;Transform stop code external value
+1 SET $PIECE(SDX,U,2)=$PIECE(^DIC(40.7,+SDX,0),U,2)_" "_$PIECE(SDX,U,2)
QUIT
+2 ;
SCCP(SDX) ;Get stop code credit pair
+1 KILL SDX
NEW SDY
DO SCBC(.SDY)
SET SDX=$EXTRACT($PIECE(SDY(1),U,2),1,3)
if SDX'?3N
KILL SDX
IF $DATA(SDX)
SET SDX=SDX_$EXTRACT($PIECE($GET(SDY(2)),U,2),1,3)
if SDX'?6N
SET SDX=$EXTRACT(SDX,1,3)_"000"
DO CPOTR
SET SDX(1)=SDX
+2 DO NX
QUIT
+3 ;
CPOTR ;Credit pair output transform
+1 NEW SDSC1,SDSC2,SDZ
+2 SET SDSC1=$ORDER(^DIC(40.7,"C",$EXTRACT(SDX,1,3),""))
if 'SDSC1
QUIT
SET SDSC1=$PIECE(^DIC(40.7,SDSC1,0),U)
SET SDSC1=$TRANSLATE(SDSC1,"/","-")
+3 IF $EXTRACT(SDX,4,6)="000"
SET SDSC2="(NONE)"
GOTO CPO1
+4 SET SDSC2=$ORDER(^DIC(40.7,"C",$EXTRACT(SDX,4,6),""))
if 'SDSC2
QUIT
SET SDSC2=$PIECE(^DIC(40.7,SDSC2,0),U)
SET SDSC2=$TRANSLATE(SDSC2,"/","-")
CPO1 IF $LENGTH(SDSC1)<17
SET SDZ=SDSC1_"/"_$EXTRACT(SDSC2,1,(17+(17-$LENGTH(SDSC1))))
GOTO CPOTQ
+1 IF $LENGTH(SDSC2)<17
SET SDZ=$EXTRACT(SDSC1,1,(17+(17-$LENGTH(SDSC2))))_"/"_SDSC2
GOTO CPOTQ
+2 SET SDZ=$EXTRACT(SDSC1,1,17)_"/"_$EXTRACT(SDSC2,1,17)
CPOTQ SET $PIECE(SDX,U,2)=$PIECE(SDX,U)_" "_SDZ
QUIT
+1 ;
VFEX(SDX) ;Get examinations
+1 KILL SDX
NEW SDY,SDI
SET SDY=+$PIECE(SDOE0,U,5)
SET SDI=0
FOR
SET SDI=$ORDER(^AUPNVXAM("AD",SDY,SDI))
if 'SDI
QUIT
SET SDX=$PIECE($GET(^AUPNVXAM(SDI,0)),U)
SET SDX=SDX_U_$PIECE($GET(^AUTTEXAM(+SDX,0)),U)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(SDI)=SDX
+2 DO NX
QUIT
+3 ;
VFHF(SDX) ;Get health factors
+1 KILL SDX
NEW SDY,SDI
SET SDY=+$PIECE(SDOE0,U,5)
SET SDI=0
FOR
SET SDI=$ORDER(^AUPNVHF("AD",SDY,SDI))
if 'SDI
QUIT
SET SDX=$PIECE($GET(^AUPNVHF(SDI,0)),U)
SET SDX=SDX_U_$PIECE($GET(^AUTTHF(+SDX,0)),U)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(SDI)=SDX
+2 DO NX
QUIT
+3 ;
VFIM(SDX) ;Get immunizations
+1 KILL SDX
NEW SDY,SDI
SET SDY=+$PIECE(SDOE0,U,5)
SET SDI=0
FOR
SET SDI=$ORDER(^AUPNVIMM("AD",SDY,SDI))
if 'SDI
QUIT
SET SDX=$PIECE($GET(^AUPNVIMM(SDI,0)),U)
SET SDX=SDX_U_$PIECE($GET(^AUTTIMM(+SDX,0)),U)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(SDI)=SDX
+2 DO NX
QUIT
+3 ;
VFPE(SDX) ;Get patient education
+1 KILL SDX
NEW SDY,SDI
SET SDY=+$PIECE(SDOE0,U,5)
SET SDI=0
FOR
SET SDI=$ORDER(^AUPNVPED("AD",SDY,SDI))
if 'SDI
QUIT
SET SDX=$PIECE($GET(^AUPNVPED(SDI,0)),U)
SET SDX=SDX_U_$PIECE($GET(^AUTTEDT(+SDX,0)),U)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(SDI)=SDX
+2 DO NX
QUIT
+3 ;
VFST(SDX) ;Get skin tests
+1 KILL SDX
NEW SDY,SDI
SET SDY=+$PIECE(SDOE0,U,5)
SET SDI=0
FOR
SET SDI=$ORDER(^AUPNVSK("AD",SDY,SDI))
if 'SDI
QUIT
SET SDX=$PIECE($GET(^AUPNVSK(SDI,0)),U)
SET SDX=SDX_U_$PIECE($GET(^AUTTSK(+SDX,0)),U)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(SDI)=SDX
+2 DO NX
QUIT
+3 ;
VFTR(SDX) ;Get treatments
+1 KILL SDX
NEW SDY,SDI
SET SDY=+$PIECE(SDOE0,U,5)
SET SDI=0
FOR
SET SDI=$ORDER(^AUPNVTRT("AD",SDY,SDI))
if 'SDI
QUIT
SET SDX=$PIECE($GET(^AUPNVTRT(SDI,0)),U)
SET SDX=SDX_U_$PIECE($GET(^AUTTTRT(+SDX,0)),U)
if $LENGTH($PIECE(SDX,U,2))
SET SDX(SDI)=SDX
+2 DO NX
QUIT
+3 ;
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
+3 ;
VETQ(DIR) ;Set up DIR array for 'veteran?' prompt
+1 SET DIR(0)="SO^Y:YES;N:NO"
SET DIR("?")="Indicates if the patient served in the U.S. armed forces."
QUIT
+2 ;
AOQ(DIR) ;Set up DIR array for agent orange prompt
+1 SET DIR(0)="SO^1:YES;0:NO"
SET DIR("?")="Indicates if the patient was exposed to agent orange."
QUIT
+2 ;
IRQ(DIR) ;Set up DIR array for ionizing radiation prompt
+1 SET DIR(0)="SO^1:YES;0:NO"
SET DIR("?")="Indicates if the patient was exposed to ionizing radiation."
QUIT
+2 ;
ECQ(DIR) ;Set up DIR array for environmental contaminants prompt
+1 SET DIR(0)="SO^Y:YES;N:NO;U:UNKNOWN"
SET DIR("?")="Indicates if the patient was exposed to environmental contaminants."
QUIT
+2 ;
POWQ(DIR) ;Set up DIR array for POW prompt
+1 SET DIR(0)="SO^1:YES;0:NO"
SET DIR("?")="Indicates if the patient was a prisoner of war."
QUIT
+2 ;
CPQ ;Credit pair help text
+1 SET SDIRQ("?",1)="Enter a six digit numeric value that represents two valid stop codes, or a"
SET SDIRQ("?",2)="valid stop code followed by three zeros for clinics that do not have a (second)"
SET SDIRQ("?")="credit stop code."
+2 ; SD*5.3*232 TEJ - Q TO PREVENT CPQ OVERRUN INTO PCAP 11/28/00
QUIT
+3 ;
PCAP(SDX,SDZ) ;Get primary care associate provider
+1 ;Required input: SDZ="C" for current, "H" for historical
+2 NEW SDI,SDATE,SDLIST,DFN
+3 DO VARZ(SDZ)
SET SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDLIST)
+4 SET SDX=$PIECE($GET(^TMP("SDPLIST",$JOB,DFN,"PCAP",1)),U,1,2)
+5 IF $LENGTH($PIECE(SDX,U,2))
SET SDX(1)=SDX
+6 KILL ^TMP("SDPLIST",$JOB,DFN)
+7 DO NX
QUIT
+8 ;
NPCP(SDX,SDZ) ;Get non-primary care provider information
+1 ;Required input: SDZ="C" for current, "H" for historical
+2 NEW SDI,SDATE,SDLIST,DFN
+3 DO VARZ(SDZ)
SET SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDLIST)
SET SDI=0
+4 FOR
SET SDI=$ORDER(^TMP("SDPLIST",$JOB,DFN,"NPCPR",SDI))
if 'SDI
QUIT
Begin DoDot:1
+5 SET SDX=$PIECE($GET(^TMP("SDPLIST",$JOB,DFN,"NPCPR",SDI)),U,1,2)
+6 IF $LENGTH($PIECE(SDX,U,2))
SET SDX(SDI)=SDX
+7 QUIT
End DoDot:1
+8 KILL ^TMP("SDPLIST",$JOB,DFN)
+9 DO NX
QUIT
+10 ;
NPCT(SDX,SDZ) ;Get non-primary care team information
+1 ;Required input: SDZ="C" for current, "H" for historical
+2 NEW SDI,SDATE,SDLIST,DFN
+3 DO VARZ(SDZ)
SET SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDLIST)
SET SDI=0
+4 FOR
SET SDI=$ORDER(^TMP("SDPLIST",$JOB,DFN,"NPCTM",SDI))
if 'SDI
QUIT
Begin DoDot:1
+5 SET SDX=$PIECE($GET(^TMP("SDPLIST",$JOB,DFN,"NPCTM",SDI)),U,1,2)
+6 IF $LENGTH($PIECE(SDX,U,2))
SET SDX(SDI)=SDX
+7 QUIT
End DoDot:1
+8 KILL ^TMP("SDPLIST",$JOB,DFN)
+9 DO NX
QUIT
+10 ;
VARZ(SDZ) ;Produce variables
+1 ;Input: SDZ="C" for current, "H" for historical
+2 SET SDLIST="^TMP(""SDPLIST"",$J)"
SET DFN=+$PIECE(SDOE0,U,2)
KILL SDX,@SDLIST
+3 SET SDATE=$SELECT(SDZ="C":DT,1:+$PIECE(SDOE0,U))
+4 SET (SDATE("BEGIN"),SDATE("END"))=SDATE
SET SDATE="SDATE"
+5 QUIT
