- BGP1UTL2 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 30 Jun 2011 9:01 AM ;
- ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
- ;
- ;
- GETDIR() ;EP - get default directory
- NEW D
- S D=""
- S D=$P($G(^BGPSITE(DUZ(2),0)),U,14)
- I D]"" Q D
- S D=$P($G(^AUTTSITE(1,1)),"^",2)
- I D]"" Q D
- S D=$P($G(^XTV(8989.3,1,"DEV")),"^",1)
- I D]"" Q D
- I $P(^AUTTSITE(1,0),U,21)=1 S D="/usr/spool/uucppublic/"
- Q D
- GETDEDIR() ;EP - get default directory
- NEW D
- S D=""
- S D=$P($G(^AUTTSITE(1,1)),"^",2)
- I D]"" Q D
- S D=$P($G(^XTV(8989.3,1,"DEV")),"^",1)
- I D]"" Q D
- I $P(^AUTTSITE(1,0),U,21)=1 S D="/usr/spool/uucppublic/"
- Q D
- GETMEDS(P,BGPMBD,BGPMED,TAXM,TAXN,TAXC,BGPDNAME,BGPZ) ;EP
- S TAXM=$G(TAXM)
- S TAXN=$G(TAXN)
- S TAXC=$G(TAXC)
- K ^TMP($J,"MEDS"),BGPZ
- S BGPDNAME=$G(BGPDNAME)
- NEW BGPC1,BGPINED,BGPINBD,BGPMIEN,BGPD,X,Y,T,T1,D,G
- S BGPC1=0 K BGPZ
- S BGPINED=(9999999-BGPMED)-1,BGPINBD=(9999999-BGPMBD)
- F S BGPINED=$O(^AUPNVMED("AA",P,BGPINED)) Q:BGPINED=""!(BGPINED>BGPINBD) D
- .S BGPMIEN=0 F S BGPMIEN=$O(^AUPNVMED("AA",P,BGPINED,BGPMIEN)) Q:BGPMIEN'=+BGPMIEN D
- ..Q:'$D(^AUPNVMED(BGPMIEN,0))
- ..S BGPD=$P(^AUPNVMED(BGPMIEN,0),U)
- ..Q:BGPD=""
- ..Q:'$D(^PSDRUG(BGPD,0))
- ..S BGPC1=BGPC1+1
- ..S ^TMP($J,"MEDS","ORDER",(9999999-BGPINED),BGPC1)=(9999999-BGPINED)_U_$P(^PSDRUG(BGPD,0),U)_U_$P(^PSDRUG(BGPD,0),U)_U_BGPMIEN_U_$P(^AUPNVMED(BGPMIEN,0),U,3)
- ;reorder
- S BGPC1=0,X=0
- F S X=$O(^TMP($J,"MEDS","ORDER",X)) Q:X'=+X D
- .S Y=0 F S Y=$O(^TMP($J,"MEDS","ORDER",X,Y)) Q:Y'=+Y D
- ..S BGPC1=BGPC1+1
- ..S ^TMP($J,"MEDS",BGPC1)=^TMP($J,"MEDS","ORDER",X,Y)
- K ^TMP($J,"MEDS","ORDER")
- S T="" I TAXM]"" S T=$O(^ATXAX("B",TAXM,0)) I T="" W BGPBOMB
- S T1="" I TAXN]"" S T1=$O(^ATXAX("B",TAXN,0)) I T1="" W BGPBOMB
- S T2="" I TAXC]"" S T2=$O(^ATXAX("B",TAXC,0))
- S BGPC1=0,X=0 F S X=$O(^TMP($J,"MEDS",X)) Q:X'=+X S Y=+$P(^TMP($J,"MEDS",X),U,4) D
- .Q:'$D(^AUPNVMED(Y,0))
- .S G=0
- .S D=$P(^AUPNVMED(Y,0),U)
- .S C=$P($G(^PSDRUG(D,0)),U,2)
- .I C]"",T2,$D(^ATXAX(T2,21,"B",C)) S G=1
- .S C=$P($G(^PSDRUG(D,2)),U,4)
- .I C]"",T1,$D(^ATXAX(T1,21,"B",C)) S G=1
- .I T,$D(^ATXAX(T,21,"B",D)) S G=1
- .I BGPDNAME]"",$P(^PSDRUG(D,0),U)[BGPDNAME S G=1
- .I TAXM="",TAXN="",TAXC="" S G=1 ;WANTS ALL MEDS
- .I G=1 S BGPC1=BGPC1+1,BGPZ(BGPC1)=^TMP($J,"MEDS",X)
- .Q
- K ^TMP($J,"MEDS")
- K BGPINED,BGPINBD,BGPMBD,BGPMED,BGPD,BGPC1,BGPDNAME
- Q
- RCIS(P,BDATE,EDATE,ICDC,CPTC) ;EP
- I '$G(P) Q ""
- I $G(BDATE)="" S BDATE=$$DOB^AUPNPAT(P)
- I $G(EDATE)="" S EDATE=DT
- S ICDC=$G(ICDC)
- S CPTC=$G(CPTC)
- ;find a referral in date range BDATE to EDATE
- NEW ICDCAT,CPTCAT,X,Y,D,A,B,G
- F X=1:1 S Y=$P(ICDC,";",X) Q:Y="" S Y=$O(^BMCTDXC("B",Y,0)) I Y S ICDCAT(Y)=""
- F X=1:1 S Y=$P(CPTC,";",X) Q:Y="" S Y=$O(^BMCTSVC("B",Y,0)) I Y S CPTCAT(Y)=""
- S X=0,G="" F S X=$O(^BMCREF("D",P,X)) Q:X'=+X!(G) D
- .Q:'$D(^BMCREF(X,0)) ;bad xref
- .S D=$P(^BMCREF(X,0),U,1),D=$P(D,".")
- .Q:D<BDATE ;before date range
- .Q:D>EDATE ;after end date
- .S Y=$P(^BMCREF(X,0),U,12)
- .I $D(ICDCAT),Y="" Q ;want certain categories and this one blank
- .I $D(ICDCAT),'$D(ICDCAT(Y)) Q ;want certain categories and this one doesn't match
- .S Y=$P(^BMCREF(X,0),U,13)
- .I $D(CPTCAT),Y="" Q ;want certain categories and this one blank
- .I $D(CPTCAT),'$D(CPTCAT(Y)) Q ;want certain categories and this one doesn't match
- .S G=X
- I 'G Q ""
- S X="" F Y=.07,.08,.09 S A=$$VAL^XBDIQ1(90001,G,Y) I A]"" S:X]"" X=X_"; "
- Q 1_"^"_$P($P(^BMCREF(G,0),U),".")_"^"_$$DATE^BGP1UTL($P($P(^BMCREF(G,0),U),"."))_"^"_"RCIS referral"_"^"_X_"^"_"90001"_"^"_G
- ;
- CHKDST() ;EP - check the demo patient search template to see if it is complete
- ;return a 1 if template is okay
- ;return a 0^message if it isn't
- ;if it isn't the caller should ask the user if they want to continue
- NEW X
- S X=$O(^DIBT("B","RPMS DEMO PATIENT NAMES",0))
- I 'X Q "0^RPMS DEMO PATIENT NAMES Search Template does not exist"
- I '$O(^DIBT(X,1,0)) Q "0^RPMS DEMO PATIENT NAMES Search Template has no entries"
- Q 1
- DSTCONT() ;EP - called to ask user if they want to continue
- NEW DIR,X,Y,DIRUT
- W !!,"Your ",$P(BGPDPST,U,2),".",!,"If you have 'DEMO' patients whose names begin with something"
- W !,"other than 'DEMO,PATIENT' they will not be excluded from this report"
- W !,"unless you update this template.",!
- S DIR(0)="Y",DIR("A")="Do you wish to continue to generate this report",DIR("B")="Y" KILL DA D ^DIR KILL DIR
- I $D(DIRUT) Q 0
- I 'Y Q 0
- Q 1
- DEMOCHK() ;EP - called to check demo patient
- NEW BGPDPST
- S BGPDPST=$$CHKDST()
- I BGPDPST Q 1 ;no action, demo template is okay
- S BGPDPST=$$DSTCONT()
- Q BGPDPST
- ;
- BGP1UTL2 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 30 Jun 2011 9:01 AM ;
- +1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
- +2 ;
- +3 ;
- GETDIR() ;EP - get default directory
- +1 NEW D
- +2 SET D=""
- +3 SET D=$PIECE($GET(^BGPSITE(DUZ(2),0)),U,14)
- +4 IF D]""
- QUIT D
- +5 SET D=$PIECE($GET(^AUTTSITE(1,1)),"^",2)
- +6 IF D]""
- QUIT D
- +7 SET D=$PIECE($GET(^XTV(8989.3,1,"DEV")),"^",1)
- +8 IF D]""
- QUIT D
- +9 IF $PIECE(^AUTTSITE(1,0),U,21)=1
- SET D="/usr/spool/uucppublic/"
- +10 QUIT D
- GETDEDIR() ;EP - get default directory
- +1 NEW D
- +2 SET D=""
- +3 SET D=$PIECE($GET(^AUTTSITE(1,1)),"^",2)
- +4 IF D]""
- QUIT D
- +5 SET D=$PIECE($GET(^XTV(8989.3,1,"DEV")),"^",1)
- +6 IF D]""
- QUIT D
- +7 IF $PIECE(^AUTTSITE(1,0),U,21)=1
- SET D="/usr/spool/uucppublic/"
- +8 QUIT D
- GETMEDS(P,BGPMBD,BGPMED,TAXM,TAXN,TAXC,BGPDNAME,BGPZ) ;EP
- +1 SET TAXM=$GET(TAXM)
- +2 SET TAXN=$GET(TAXN)
- +3 SET TAXC=$GET(TAXC)
- +4 KILL ^TMP($JOB,"MEDS"),BGPZ
- +5 SET BGPDNAME=$GET(BGPDNAME)
- +6 NEW BGPC1,BGPINED,BGPINBD,BGPMIEN,BGPD,X,Y,T,T1,D,G
- +7 SET BGPC1=0
- KILL BGPZ
- +8 SET BGPINED=(9999999-BGPMED)-1
- SET BGPINBD=(9999999-BGPMBD)
- +9 FOR
- SET BGPINED=$ORDER(^AUPNVMED("AA",P,BGPINED))
- IF BGPINED=""!(BGPINED>BGPINBD)
- QUIT
- Begin DoDot:1
- +10 SET BGPMIEN=0
- FOR
- SET BGPMIEN=$ORDER(^AUPNVMED("AA",P,BGPINED,BGPMIEN))
- IF BGPMIEN'=+BGPMIEN
- QUIT
- Begin DoDot:2
- +11 IF '$DATA(^AUPNVMED(BGPMIEN,0))
- QUIT
- +12 SET BGPD=$PIECE(^AUPNVMED(BGPMIEN,0),U)
- +13 IF BGPD=""
- QUIT
- +14 IF '$DATA(^PSDRUG(BGPD,0))
- QUIT
- +15 SET BGPC1=BGPC1+1
- +16 SET ^TMP($JOB,"MEDS","ORDER",(9999999-BGPINED),BGPC1)=(9999999-BGPINED)_U_$PIECE(^PSDRUG(BGPD,0),U)_U_$PIECE(^PSDRUG(BGPD,0),U)_U_BGPMIEN_U_$PIECE(^AUPNVMED(BGPMIEN,0),U,3)
- End DoDot:2
- End DoDot:1
- +17 ;reorder
- +18 SET BGPC1=0
- SET X=0
- +19 FOR
- SET X=$ORDER(^TMP($JOB,"MEDS","ORDER",X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +20 SET Y=0
- FOR
- SET Y=$ORDER(^TMP($JOB,"MEDS","ORDER",X,Y))
- IF Y'=+Y
- QUIT
- Begin DoDot:2
- +21 SET BGPC1=BGPC1+1
- +22 SET ^TMP($JOB,"MEDS",BGPC1)=^TMP($JOB,"MEDS","ORDER",X,Y)
- End DoDot:2
- End DoDot:1
- +23 KILL ^TMP($JOB,"MEDS","ORDER")
- +24 SET T=""
- IF TAXM]""
- SET T=$ORDER(^ATXAX("B",TAXM,0))
- IF T=""
- WRITE BGPBOMB
- +25 SET T1=""
- IF TAXN]""
- SET T1=$ORDER(^ATXAX("B",TAXN,0))
- IF T1=""
- WRITE BGPBOMB
- +26 SET T2=""
- IF TAXC]""
- SET T2=$ORDER(^ATXAX("B",TAXC,0))
- +27 SET BGPC1=0
- SET X=0
- FOR
- SET X=$ORDER(^TMP($JOB,"MEDS",X))
- IF X'=+X
- QUIT
- SET Y=+$PIECE(^TMP($JOB,"MEDS",X),U,4)
- Begin DoDot:1
- +28 IF '$DATA(^AUPNVMED(Y,0))
- QUIT
- +29 SET G=0
- +30 SET D=$PIECE(^AUPNVMED(Y,0),U)
- +31 SET C=$PIECE($GET(^PSDRUG(D,0)),U,2)
- +32 IF C]""
- IF T2
- IF $DATA(^ATXAX(T2,21,"B",C))
- SET G=1
- +33 SET C=$PIECE($GET(^PSDRUG(D,2)),U,4)
- +34 IF C]""
- IF T1
- IF $DATA(^ATXAX(T1,21,"B",C))
- SET G=1
- +35 IF T
- IF $DATA(^ATXAX(T,21,"B",D))
- SET G=1
- +36 IF BGPDNAME]""
- IF $PIECE(^PSDRUG(D,0),U)[BGPDNAME
- SET G=1
- +37 ;WANTS ALL MEDS
- IF TAXM=""
- IF TAXN=""
- IF TAXC=""
- SET G=1
- +38 IF G=1
- SET BGPC1=BGPC1+1
- SET BGPZ(BGPC1)=^TMP($JOB,"MEDS",X)
- +39 QUIT
- End DoDot:1
- +40 KILL ^TMP($JOB,"MEDS")
- +41 KILL BGPINED,BGPINBD,BGPMBD,BGPMED,BGPD,BGPC1,BGPDNAME
- +42 QUIT
- RCIS(P,BDATE,EDATE,ICDC,CPTC) ;EP
- +1 IF '$GET(P)
- QUIT ""
- +2 IF $GET(BDATE)=""
- SET BDATE=$$DOB^AUPNPAT(P)
- +3 IF $GET(EDATE)=""
- SET EDATE=DT
- +4 SET ICDC=$GET(ICDC)
- +5 SET CPTC=$GET(CPTC)
- +6 ;find a referral in date range BDATE to EDATE
- +7 NEW ICDCAT,CPTCAT,X,Y,D,A,B,G
- +8 FOR X=1:1
- SET Y=$PIECE(ICDC,";",X)
- IF Y=""
- QUIT
- SET Y=$ORDER(^BMCTDXC("B",Y,0))
- IF Y
- SET ICDCAT(Y)=""
- +9 FOR X=1:1
- SET Y=$PIECE(CPTC,";",X)
- IF Y=""
- QUIT
- SET Y=$ORDER(^BMCTSVC("B",Y,0))
- IF Y
- SET CPTCAT(Y)=""
- +10 SET X=0
- SET G=""
- FOR
- SET X=$ORDER(^BMCREF("D",P,X))
- IF X'=+X!(G)
- QUIT
- Begin DoDot:1
- +11 ;bad xref
- IF '$DATA(^BMCREF(X,0))
- QUIT
- +12 SET D=$PIECE(^BMCREF(X,0),U,1)
- SET D=$PIECE(D,".")
- +13 ;before date range
- IF D<BDATE
- QUIT
- +14 ;after end date
- IF D>EDATE
- QUIT
- +15 SET Y=$PIECE(^BMCREF(X,0),U,12)
- +16 ;want certain categories and this one blank
- IF $DATA(ICDCAT)
- IF Y=""
- QUIT
- +17 ;want certain categories and this one doesn't match
- IF $DATA(ICDCAT)
- IF '$DATA(ICDCAT(Y))
- QUIT
- +18 SET Y=$PIECE(^BMCREF(X,0),U,13)
- +19 ;want certain categories and this one blank
- IF $DATA(CPTCAT)
- IF Y=""
- QUIT
- +20 ;want certain categories and this one doesn't match
- IF $DATA(CPTCAT)
- IF '$DATA(CPTCAT(Y))
- QUIT
- +21 SET G=X
- End DoDot:1
- +22 IF 'G
- QUIT ""
- +23 SET X=""
- FOR Y=.07,.08,.09
- SET A=$$VAL^XBDIQ1(90001,G,Y)
- IF A]""
- IF X]""
- SET X=X_"; "
- +24 QUIT 1_"^"_$PIECE($PIECE(^BMCREF(G,0),U),".")_"^"_$$DATE^BGP1UTL($PIECE($PIECE(^BMCREF(G,0),U),"."))_"^"_"RCIS referral"_"^"_X_"^"_"90001"_"^"_G
- +25 ;
- CHKDST() ;EP - check the demo patient search template to see if it is complete
- +1 ;return a 1 if template is okay
- +2 ;return a 0^message if it isn't
- +3 ;if it isn't the caller should ask the user if they want to continue
- +4 NEW X
- +5 SET X=$ORDER(^DIBT("B","RPMS DEMO PATIENT NAMES",0))
- +6 IF 'X
- QUIT "0^RPMS DEMO PATIENT NAMES Search Template does not exist"
- +7 IF '$ORDER(^DIBT(X,1,0))
- QUIT "0^RPMS DEMO PATIENT NAMES Search Template has no entries"
- +8 QUIT 1
- DSTCONT() ;EP - called to ask user if they want to continue
- +1 NEW DIR,X,Y,DIRUT
- +2 WRITE !!,"Your ",$PIECE(BGPDPST,U,2),".",!,"If you have 'DEMO' patients whose names begin with something"
- +3 WRITE !,"other than 'DEMO,PATIENT' they will not be excluded from this report"
- +4 WRITE !,"unless you update this template.",!
- +5 SET DIR(0)="Y"
- SET DIR("A")="Do you wish to continue to generate this report"
- SET DIR("B")="Y"
- KILL DA
- DO ^DIR
- KILL DIR
- +6 IF $DATA(DIRUT)
- QUIT 0
- +7 IF 'Y
- QUIT 0
- +8 QUIT 1
- DEMOCHK() ;EP - called to check demo patient
- +1 NEW BGPDPST
- +2 SET BGPDPST=$$CHKDST()
- +3 ;no action, demo template is okay
- IF BGPDPST
- QUIT 1
- +4 SET BGPDPST=$$DSTCONT()
- +5 QUIT BGPDPST
- +6 ;
