BDMPROB ; IHS/CMI/LAB - ;
;;2.0;IHS PCC SUITE;**4**;JUN 14, 2007
;
;
ADDPROB(APCDDX,APCDP,APCDDLM,APCDCLS,APCDN,APCDFAC,APCDDTE,APCDSTAT,APCDDOO,APCDCLAS,APCDEBU,APCDEC1,APCDEC2,APCDEC3) ;PEP called to non-interactively add a problem to the pcc problem list
;APCDDX is the dx - pass in "`"_ien format or pass code (required)
;APCDP is the patient dfn (required)
;APCDDLM is the date last modified, if null I will stuff DT, PASS IN EXTERNAL FORMAT PLEASE
;APCDCLS is the class (not required)
;APCDN - provider narrative pass either "`"_ien of prov narr or pass narrative text
;APCDFAC - facility ien, if null will use DUZ(2)
;APCDDTE - date entered, if null will use DT , PASS IN EXTERNAL FORMAT PLEASE
;APCDSTAT - status I or A WILL DEFAULT TO A IF NONE PASSED
;APCDDOO - date of onset (pass in EXTERNAL format please) (not required)
;APCDCLAS= .15 field
;APCDEBU = ENTERED BY (field 1.03) if blank is stuffed with DUZ
;APCDEC1, APCDEC2, APCDEC3 - E CODES pass in "`"_ien format or pass code (required)
;
;error codes will be past back
; 1 = invalid dx, either not a valid ien, inactive code, E code
; 2 = invalid patient dfn, either not a valid dfn or patient merged
; 3 = invalid class code
; 4 = error creating entry with FILE^DICN
; 5 = invalid date last modified
; 6 = invalid provider narrative
; 7 = invalid date entered
; 8 = invalid facility
; 9 = invalid status
; 10 = invalid date of onset
; 11 = invalid ecode 1
; 12 = invalid ecode 2
; 13 = invalid ecode 3
;
NEW APCDERR
S APCDERR=0
D EN^XBNEW("AP^BDMPROB","APCDDX;APCDP;APCDDLM;APCDCLS;APCDN;APCDFAC;APCDDTE;APCDSTAT;APCDDOO;APCDCLAS;APCDEBU;APCDERR;APCDEC1;APCDEC2;APCDEC3")
Q APCDERR
;
AP ;EP
NEW IEN,%,F,%FDA
P I '$G(APCDP) S APCDERR=2 Q
I '$D(^DPT(APCDP)) S APCDERR=2 Q
I $P(^DPT(APCDP,0),U,19) S APCDERR=2 Q
I '$D(^AUPNPAT(APCDP)) S APCDERR=2 Q
S Y=APCDP D ^AUPNPAT
DX ;DX CHK
I $G(APCDDX)="" S APCDERR=1 Q
D CHK^DIE(9000011,.01,"",APCDDX,.%) I %="^" S APCDERR=1 Q
S APCDDX=%
DLM ;
I $G(APCDDLM)="" S APCDDLM=$$FMTE^XLFDT(DT,"1D")
D CHK^DIE(9000011,.03,"",APCDDLM,.%) I %="^" S APCDERR=5 Q
CLS ;
I $G(APCDCLS)="" S APCDCLS=""
I APCDCLS]"" D Q:APCDERR
.D CHK^DIE(9000011,.04,"",APCDCLS,.%) I %="^" S APCDERR=3 Q
NARR ;
I $G(APCDN)="" S APCDERR=6 Q
I $$CHKNARR(APCDN) S APCDERR=6 Q
FAC ;
I '$G(APCDFAC) S APCDFAC=DUZ(2)
I '$D(^AUTTLOC(APCDFAC)) S APCDERR=8 Q
DTE ;
I $G(APCDDTE)="" S APCDDTE=$$FMTE^XLFDT(DT,"1D")
D CHK^DIE(9000011,.08,"",APCDDTE,.%) I %="^" S APCDERR=7 Q
STATUS ;
I $G(APCDSTAT)="" S APCDSTAT="A" G DOO
D CHK^DIE(9000011,.12,"",APCDSTAT,.%) I %="^" S APCDERR=9 Q
DOO ;
S:$G(APCDDOO)="" APCDDOO="" G CLASS
D CHK^DIE(9000011,.13,"",APCDDOO,.%) I %="^" S APCDERR=10 Q
CLASS ;
S APCDCLAS=$G(APCDCLAS)
S APCDEC1=$G(APCDEC1)
I APCDEC1 D CHK^DIE(9000011,.16,"",APCDEC1,.%) I %="^" S APCDERR=11 Q
S APCDEC2=$G(APCDEC2)
I APCDEC2 D CHK^DIE(9000011,.17,"",APCDEC2,.%) I %="^" S APCDERR=12 Q
S APCDEC3=$G(APCDEC3)
I APCDEC3 D CHK^DIE(9000011,.18,"",APCDEC3,.%) I %="^" S APCDERR=13 Q
NMBR ;calculate new number
NEW X,Y S X=0,Y="" F S Y=$O(^AUPNPROB("AA",APCDP,APCDFAC,Y)) S:Y'="" X=$E(Y,2,4) I Y="" S X=X+1 K Y Q
S APCDNMBR=X
FILE ;
S APCDOVRR=1,APCDALVR=""
S X=APCDDX,DIC(0)="L",DIC="^AUPNPROB(",DLAYGO=9000011,DIADD=1
S DIC("DR")=".02////"_APCDP_";.03///"_APCDDLM_";.04///"_APCDCLS_";.05///"_APCDN_";.06////"_APCDFAC_";.08///"_APCDDTE_";.07///"_APCDNMBR_";.12///"_APCDSTAT_";.13///"_APCDDOO_";1.03////"_$S($G(APCDEBU):APCDEBU,1:DUZ)_";.15///"_APCDCLAS
S DIC("DR")=DIC("DR")_";.16///"_APCDEC1_";.17///"_APCDEC2_";.18///"_APCDEC3
K DD,DO D FILE^DICN K DD,DO,DR,DLAYGO,DIADD,DIC
I Y=-1 S APCDERR=4 Q
Q
CHKNARR(D) ;
NEW %,F
S F=0
I $E(D)="`" S D=$P(D,"`",2) D Q F
.I '$D(^AUTNPOV(D)) S F=1
.;S APCDN=D
.Q
S X=D X $P(^DD(9999999.27,.01,0),U,5,99)
I '$D(X) S F=1
Q F
DELPROB(P,REASON,OTHER) ;PEP called to delete a problem from the PCC Problem list
;non interactive -1 will be returned if a valid problem ien was not passed
;sets .12 field to D, sets 2.01 to DUZ, set 2.02 to $$NOW
;if passed sets 2.03 to REASON
;if passed, sets 2.04 to OTHER
NEW DA,DIE,DR
I '$G(P) Q -1
I '$D(^AUPNPROB(P)) Q -1
S REASON=$G(REASON)
S OTHER=$G(OTHER)
S DA=P ;,DIK="^AUPNPROB(" D ^DIK
S DIE="^AUPNPROB("
S DR=".12////D;2.01////"_DUZ_";2.02///^S X=$$NOW^XLFDT;2.03///"_REASON_";2.04///"_OTHER
D ^DIE K DA,DR,DIE
I $D(Y) Q "-1^INVALID DATA"
Q ""
TEST ;APCDDX,APCDP,APCDDLM,APCDCLS,APCDN,APCDFAC,APCDDTE,APCDSTAT,APCDDOO,APCDCLAS,APCDEBU,APCDEC1,APCDEC2,APCDEC3
S X=$$ADDPROB(250.00,10,3101111,,"THIS IS MY NARRATIVE",5217,3101111,"A",,"P",,"E000.9","E800.1","E000.0")
W !,X
Q
TESTDEL ;
S X=$$DELPROB(1200,"OTHER","PROBLEM IS RESOLVED")
W !,X
Q
BDMPROB ; IHS/CMI/LAB - ;
+1 ;;2.0;IHS PCC SUITE;**4**;JUN 14, 2007
+2 ;
+3 ;
ADDPROB(APCDDX,APCDP,APCDDLM,APCDCLS,APCDN,APCDFAC,APCDDTE,APCDSTAT,APCDDOO,APCDCLAS,APCDEBU,APCDEC1,APCDEC2,APCDEC3) ;PEP called to non-interactively add a problem to the pcc problem list
+1 ;APCDDX is the dx - pass in "`"_ien format or pass code (required)
+2 ;APCDP is the patient dfn (required)
+3 ;APCDDLM is the date last modified, if null I will stuff DT, PASS IN EXTERNAL FORMAT PLEASE
+4 ;APCDCLS is the class (not required)
+5 ;APCDN - provider narrative pass either "`"_ien of prov narr or pass narrative text
+6 ;APCDFAC - facility ien, if null will use DUZ(2)
+7 ;APCDDTE - date entered, if null will use DT , PASS IN EXTERNAL FORMAT PLEASE
+8 ;APCDSTAT - status I or A WILL DEFAULT TO A IF NONE PASSED
+9 ;APCDDOO - date of onset (pass in EXTERNAL format please) (not required)
+10 ;APCDCLAS= .15 field
+11 ;APCDEBU = ENTERED BY (field 1.03) if blank is stuffed with DUZ
+12 ;APCDEC1, APCDEC2, APCDEC3 - E CODES pass in "`"_ien format or pass code (required)
+13 ;
+14 ;error codes will be past back
+15 ; 1 = invalid dx, either not a valid ien, inactive code, E code
+16 ; 2 = invalid patient dfn, either not a valid dfn or patient merged
+17 ; 3 = invalid class code
+18 ; 4 = error creating entry with FILE^DICN
+19 ; 5 = invalid date last modified
+20 ; 6 = invalid provider narrative
+21 ; 7 = invalid date entered
+22 ; 8 = invalid facility
+23 ; 9 = invalid status
+24 ; 10 = invalid date of onset
+25 ; 11 = invalid ecode 1
+26 ; 12 = invalid ecode 2
+27 ; 13 = invalid ecode 3
+28 ;
+29 NEW APCDERR
+30 SET APCDERR=0
+31 DO EN^XBNEW("AP^BDMPROB","APCDDX;APCDP;APCDDLM;APCDCLS;APCDN;APCDFAC;APCDDTE;APCDSTAT;APCDDOO;APCDCLAS;APCDEBU;APCDERR;APCDEC1;APCDEC2;APCDEC3")
+32 QUIT APCDERR
+33 ;
AP ;EP
+1 NEW IEN,%,F,%FDA
P IF '$GET(APCDP)
SET APCDERR=2
QUIT
+1 IF '$DATA(^DPT(APCDP))
SET APCDERR=2
QUIT
+2 IF $PIECE(^DPT(APCDP,0),U,19)
SET APCDERR=2
QUIT
+3 IF '$DATA(^AUPNPAT(APCDP))
SET APCDERR=2
QUIT
+4 SET Y=APCDP
DO ^AUPNPAT
DX ;DX CHK
+1 IF $GET(APCDDX)=""
SET APCDERR=1
QUIT
+2 DO CHK^DIE(9000011,.01,"",APCDDX,.%)
IF %="^"
SET APCDERR=1
QUIT
+3 SET APCDDX=%
DLM ;
+1 IF $GET(APCDDLM)=""
SET APCDDLM=$$FMTE^XLFDT(DT,"1D")
+2 DO CHK^DIE(9000011,.03,"",APCDDLM,.%)
IF %="^"
SET APCDERR=5
QUIT
CLS ;
+1 IF $GET(APCDCLS)=""
SET APCDCLS=""
+2 IF APCDCLS]""
Begin DoDot:1
+3 DO CHK^DIE(9000011,.04,"",APCDCLS,.%)
IF %="^"
SET APCDERR=3
QUIT
End DoDot:1
IF APCDERR
QUIT
NARR ;
+1 IF $GET(APCDN)=""
SET APCDERR=6
QUIT
+2 IF $$CHKNARR(APCDN)
SET APCDERR=6
QUIT
FAC ;
+1 IF '$GET(APCDFAC)
SET APCDFAC=DUZ(2)
+2 IF '$DATA(^AUTTLOC(APCDFAC))
SET APCDERR=8
QUIT
DTE ;
+1 IF $GET(APCDDTE)=""
SET APCDDTE=$$FMTE^XLFDT(DT,"1D")
+2 DO CHK^DIE(9000011,.08,"",APCDDTE,.%)
IF %="^"
SET APCDERR=7
QUIT
STATUS ;
+1 IF $GET(APCDSTAT)=""
SET APCDSTAT="A"
GOTO DOO
+2 DO CHK^DIE(9000011,.12,"",APCDSTAT,.%)
IF %="^"
SET APCDERR=9
QUIT
DOO ;
+1 IF $GET(APCDDOO)=""
SET APCDDOO=""
GOTO CLASS
+2 DO CHK^DIE(9000011,.13,"",APCDDOO,.%)
IF %="^"
SET APCDERR=10
QUIT
CLASS ;
+1 SET APCDCLAS=$GET(APCDCLAS)
+2 SET APCDEC1=$GET(APCDEC1)
+3 IF APCDEC1
DO CHK^DIE(9000011,.16,"",APCDEC1,.%)
IF %="^"
SET APCDERR=11
QUIT
+4 SET APCDEC2=$GET(APCDEC2)
+5 IF APCDEC2
DO CHK^DIE(9000011,.17,"",APCDEC2,.%)
IF %="^"
SET APCDERR=12
QUIT
+6 SET APCDEC3=$GET(APCDEC3)
+7 IF APCDEC3
DO CHK^DIE(9000011,.18,"",APCDEC3,.%)
IF %="^"
SET APCDERR=13
QUIT
NMBR ;calculate new number
+1 NEW X,Y
SET X=0
SET Y=""
FOR
SET Y=$ORDER(^AUPNPROB("AA",APCDP,APCDFAC,Y))
IF Y'=""
SET X=$EXTRACT(Y,2,4)
IF Y=""
SET X=X+1
KILL Y
QUIT
+2 SET APCDNMBR=X
FILE ;
+1 SET APCDOVRR=1
SET APCDALVR=""
+2 SET X=APCDDX
SET DIC(0)="L"
SET DIC="^AUPNPROB("
SET DLAYGO=9000011
SET DIADD=1
+3 SET DIC("DR")=".02////"_APCDP_";.03///"_APCDDLM_";.04///"_APCDCLS_";.05///"_APCDN_";.06////"_APCDFAC_";.08///"_APCDDTE_";.07///"_APCDNMBR_";.12///"_APCDSTAT_";.13///"_APCDDOO_";1.03////"_$SELECT($GET(APCDEBU):APCDEBU,1:DUZ)_";.15///"_APCDCLAS
+4 SET DIC("DR")=DIC("DR")_";.16///"_APCDEC1_";.17///"_APCDEC2_";.18///"_APCDEC3
+5 KILL DD,DO
DO FILE^DICN
KILL DD,DO,DR,DLAYGO,DIADD,DIC
+6 IF Y=-1
SET APCDERR=4
QUIT
+7 QUIT
CHKNARR(D) ;
+1 NEW %,F
+2 SET F=0
+3 IF $EXTRACT(D)="`"
SET D=$PIECE(D,"`",2)
Begin DoDot:1
+4 IF '$DATA(^AUTNPOV(D))
SET F=1
+5 ;S APCDN=D
+6 QUIT
End DoDot:1
QUIT F
+7 SET X=D
XECUTE $PIECE(^DD(9999999.27,.01,0),U,5,99)
+8 IF '$DATA(X)
SET F=1
+9 QUIT F
DELPROB(P,REASON,OTHER) ;PEP called to delete a problem from the PCC Problem list
+1 ;non interactive -1 will be returned if a valid problem ien was not passed
+2 ;sets .12 field to D, sets 2.01 to DUZ, set 2.02 to $$NOW
+3 ;if passed sets 2.03 to REASON
+4 ;if passed, sets 2.04 to OTHER
+5 NEW DA,DIE,DR
+6 IF '$GET(P)
QUIT -1
+7 IF '$DATA(^AUPNPROB(P))
QUIT -1
+8 SET REASON=$GET(REASON)
+9 SET OTHER=$GET(OTHER)
+10 ;,DIK="^AUPNPROB(" D ^DIK
SET DA=P
+11 SET DIE="^AUPNPROB("
+12 SET DR=".12////D;2.01////"_DUZ_";2.02///^S X=$$NOW^XLFDT;2.03///"_REASON_";2.04///"_OTHER
+13 DO ^DIE
KILL DA,DR,DIE
+14 IF $DATA(Y)
QUIT "-1^INVALID DATA"
+15 QUIT ""
TEST ;APCDDX,APCDP,APCDDLM,APCDCLS,APCDN,APCDFAC,APCDDTE,APCDSTAT,APCDDOO,APCDCLAS,APCDEBU,APCDEC1,APCDEC2,APCDEC3
+1 SET X=$$ADDPROB(250.00,10,3101111,,"THIS IS MY NARRATIVE",5217,3101111,"A",,"P",,"E000.9","E800.1","E000.0")
+2 WRITE !,X
+3 QUIT
TESTDEL ;
+1 SET X=$$DELPROB(1200,"OTHER","PROBLEM IS RESOLVED")
+2 WRITE !,X
+3 QUIT
