- 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 Feb 19, 2025@00:09:56 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