IBDFDE5 ;ALB/AAS - AICS Manual Data Entry, Loader routine for 357.6 ; 19-APR-96
;;3.0;AUTOMATED INFO COLLECTION SYS;**40**;APR 24, 1997
;
% G ^IBDFDE
;
;
COMPLST ; -- procedure, compile form list arrays in ^tmp
; ^tmp("ibd-lText",$j,form,package interface,list,text,cnt,n)=entry number
; ^tmp("ibd-lCode",$j,form,package interface,list," "_code,cnt,n)= entry number
; ^tmp("ibd-lst",$j,form,package inteface,list)=display text^display code^input value^ optional caption^ optional term^selectable?
;
N IBDI,FORM,PI,IEN,CNT,CH,CODE
I '$G(IBDF("PI"))!('$G(IBDF("IEN")))!('$G(IBDFMIEN)) G COMPQ
S PI=IBDF("PI"),IEN=IBDF("IEN"),FORM=IBDFMIEN
;
;K ^TMP("IBD-LST",$J,FORM,PI,IEN),^TMP("IBD-LTEXT",$J,FORM,PI,IEN),^TMP("IBD-LCODE",$J,FORM,PI,IEN)
K ^TMP("IBD-LTEXT",$J,FORM,PI,IEN),^TMP("IBD-LCODE",$J,FORM,PI,IEN)
;
;M ^TMP("IBD-LST",$J,FORM,PI,IEN)=CHOICE
K CHOICE
;
; -- Expand choices
S HDR=""
S IBDI=0 F S IBDI=$O(^TMP("IBD-LST",$J,FORM,PI,IEN,IBDI)) Q:'IBDI S CH=$G(^(IBDI)) D
.I $P(CH,"^",7)=0 S HDR=$P(CH,"^") Q
.I $P(CH,"^",8)="" S $P(^TMP("IBD-LST",$J,FORM,PI,IEN,IBDI),"^",8)=HDR
.;
.; -- build array of text
.I $P(CH,"^",1)'="" D
..I '$D(^TMP("IBD-LTEXT",$J,FORM,PI,IEN,$E($$UP^XLFSTR($P(CH,"^",1)),1,80))) S ^TMP("IBD-LTEXT",$J,FORM,PI,IEN,$E($$UP^XLFSTR($P(CH,"^",1)),1,80),1)=IBDI Q
..S CNT=$O(^TMP("IBD-LTEXT",$J,FORM,PI,IEN,$E($$UP^XLFSTR($P(CH,"^",1)),1,80),""),-1)
..S ^TMP("IBD-LTEXT",$J,FORM,PI,IEN,$E($$UP^XLFSTR($P(CH,"^",1)),1,80),CNT+1)=IBDI
.;
.; -- build array of codes
.S CODE=$S($P(CH,"^",2)'="":$P(CH,"^",2),1:$P(CH,"^",3)) Q:CODE=""
.I '$D(^TMP("IBD-LCODE",$J,FORM,PI,IEN," "_CODE,1)) S ^TMP("IBD-LCODE",$J,FORM,PI,IEN," "_CODE,1)=IBDI Q
.S CNT=$O(^TMP("IBD-LCODE",$J,FORM,PI,IEN," "_CODE,""),-1) S ^TMP("IBD-LCODE",$J,FORM,PI,IEN," "_CODE,CNT+1)=IBDI
;
COMPQ Q
;
MDCOMP(FORM) ; -- compile form for manual data entry into ^xtmp
; -- ^xtmp("ibd"_form,0) := date ^ date
; ^xtmp("ibd"_form, "ibd-obj", n) := object listing for form
; ^xtmp("ibd"_form, "ibd-lst", pkg interface, list, n) := listing of each list
; ^xtmp("ibd"_form, "ibd-lst", pkg interface, list ,"code", " "_code, n) := code index
; ^xtmp("ibd"_form, "ibd-lst", pkg interface, list "text", text, n) := text index
;
; -- before converting to xtmp must resolve compile issues,
; such as when form is in use for data entry etc.
; need schema for locks...think about this
; remember to check old logic for changes
;
N I,J,X,Y,NAM,IBDOBJ
G:$G(^IBE(357,+$G(FORM),0))="" MDCQ
S NAM="IBD"_FORM
L +^XTMP(NAM):10 I '$T W !!,"form is in use, data entry compile failed",! S IBQUIT=1 G MDCQ
K ^XTMP(NAM) ; make sure ibdfde locks so doesn't kill when in use
S ^XTMP(NAM,0)=$$FMADD^XLFDT(DT,90)_"^"_DT
D FRMLSTI^IBDFRPC(.IBDOBJ,FORM,"",1)
M ^XTMP(NAM,"IBD-OBJ")=IBDOBJ
K IBDOBJ
;
; -- build entry for lists
S X=0 F S X=$O(^XTMP(NAM,"IBD-OBJ",X)) Q:'X S Y=^(X) D
.Q:$P($G(^IBE(357.6,+$P(Y,"^",2),0)),"^",14) ;dyanamic lists get compiled by ibdfde2 and then killed
.I $P(Y,"^",5)="LIST" D MDCLIST(FORM,$P(Y,"^",2),$P(Y,"^",6))
;
MDCQ L -^XTMP(NAM)
Q
;
MDCLIST(FORM,PI,LIST) ; -- Compile one list
N I,J,X,Y,IBDF,CH,CODE
G:$G(^IBE(357.6,+$G(PI),0))=""!($G(^IBE(357.2,+$G(LIST),0))="")!($G(^IBE(357,+$G(FORM),0))="") MDCLQ
S IBDF("PI")=PI,IBDF("IEN")=LIST,IBDF("TYPE")="LIST"
K ^XTMP("IBD"_FORM,"IBD-LST",PI,LIST)
D OBJLST^IBDFRPC1(.CH,.IBDF)
M ^XTMP("IBD"_FORM,"IBD-LST",PI,LIST)=CH
;
; -- Expand choices
S HDR=""
S IBDI=0 F S IBDI=$O(^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,IBDI)) Q:'IBDI S CH=^(IBDI) D
.I $P(CH,"^",7)=0 S HDR=$P(CH,"^") Q
.I $P(CH,"^",8)="" S $P(^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,I),"^",8)=HDR
.;
.; -- build array of text
.I $P(CH,"^",1)'="" D
..I '$D(^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"TEXT",$$UP^XLFSTR($P(CH,"^",1)))) S ^XTMP("IBD"_FORM,PI,LIST,"TEXT",$$UP^XLFSTR($P(CH,"^",1)),1)=IBDI Q
..S CNT=$O(^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"TEXT",$$UP^XLFSTR($P(CH,"^",1)),""),-1)
..S ^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"TEXT",$$UP^XLFSTR($P(CH,"^",1)),CNT+1)=IBDI
.;
.; -- build array of codes
.S CODE=$S($P(CH,"^",2)'="":$P(CH,"^",2),1:$P(CH,"^",3)) Q:CODE=""
.I '$D(^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"CODE"," "_CODE,1)) S ^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"CODE"," "_CODE,1)=IBDI Q
.S CNT=$O(^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"CODE"," "_CODE,""),-1) S ^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"CODE"," "_CODE,CNT+1)=IBDI
.Q
;
MDCLQ Q
;
18 ; -- Post init for data entry patch
D 14,CLNTMP,XREF,PIDIM,PIUP
Q
;
14 ;Populate the .14 FIELD IN FILE 357.96
S ZTIO="",ZTDTH=$H,ZTRTN="DQ^IBDFDE5",ZTDESC="IBD-Patch 2 populate 357.96;.14" D ^%ZTLOAD
D BMES^XPDUTL("Queing the Conversion to populate the .14 field (NO APPOINTMENT ENTRY) of file 357.96 ENCOUNTER FORM TRACKING......")
Q
;
DQ ;
N IBDFIFN,IBDFCLIN,IBDFAPPT,IBDFDFN
S IBDFIFN=0
F S IBDFIFN=$O(^IBD(357.96,IBDFIFN)) Q:'IBDFIFN S IBDFNODE=$G(^IBD(357.96,IBDFIFN,0)) S IBDFDFN=$P(IBDFNODE,"^",2),IBDFAPPT=$P(IBDFNODE,"^",3) I IBDFDFN,IBDFAPPT D
.S DIE="^IBD(357.96,",DA=IBDFIFN
.I $D(^DPT(+IBDFIFN,"S",IBDFAPPT)) S DR=".14////0"
.E S DR=".14////1"
.D ^DIE K DA,DR,DIE
;W !!,"DONE"
Q
CLNTMP ; -- kill tmp globals, on load, forces rebuild with updates
K ^TMP("IBD-LST"),^TMP("IBD-OBJ")
Q
;
XREF ;
D BMES^XPDUTL("Removing 'RECD' cross-reference on PRINTED FORM ID field")
S DA=0
F S DA=$O(^DD(357.96,.01,1,DA)) Q:DA<1 I $G(^(DA,0))="357.96^RECD^MUMPS" S DIK="^DD(357.96,.01,1,",DA(2)=357.96,DA(1)=.01 D ^DIK K DIK
;
D BMES^XPDUTL("Removing 'RECD2' cross-reference on DATE/TIME RECEIVED IN VISTA field")
S DA=0
F S DA=$O(^DD(357.96,.06,1,DA)) Q:DA<1 I $G(^(DA,0))="357.96^RECD2^MUMPS" S DIK="^DD(357.96,.06,1,",DA(2)=357.96,DA(1)=.06 D ^DIK K DIK
;
D BMES^XPDUTL("Removing 'RECD3' cross-reference on DATE/TIME PRINTED field")
S DA=0
F S DA=$O(^DD(357.96,.05,1,DA)) Q:DA<1 I $G(^(DA,0))="357.96^RECD3^MUMPS" S DIK="^DD(357.96,.05,1,",DA(2)=357.96,DA(1)=.05 D ^DIK K DIK
K DA
K ^IBD(357.96,"RECD")
Q
;
PIDIM ;
D BMES^XPDUTL("Updating PCE DIM OUTPUT TRANSFORM in file 357.6")
N IBD,LINE,PKG,NOD14,IEN
F IBD=1:1 S LINE=$P($T(OUTTRANS+IBD),";;",2) Q:LINE="" D
.S PKG=$P(LINE,"^",2)
.S NOD14=$P(LINE,"^",3,99)
.S IEN=+$O(^IBE(357.6,"B",$E(PKG,1,30),0))
.Q:IEN<1
.I $P($G(^IBE(357.6,IEN,0)),"^")=PKG S ^IBE(357.6,IEN,14)=NOD14
Q
OUTTRANS ;;
;;61^INPUT PROVIDER^S Y=$$DSPLYPRV^IBDFN9(Y)
;;62^INPUT VISIT TYPE^S Y=$$DSPLYCPT^IBDFN9(Y)
;;102^PX INPUT VISIT TYPE^S Y=$$DSPLYCPT^IBDFN9(Y)
;;
PIUP ;
D BMES^XPDUTL("Updating Package Interface File for Data Entry")
N PKG,ENT,RTN,DYN,NODE18,IEN
F IBD=1:1 S LINE=$P($T(UPDATE+IBD),";;",2) Q:LINE="" D
.S PKG=$P(LINE,"^",2)
.S ENT=$P(LINE,"^",3)
.S RTN=$P(LINE,"^",4)
.S DYN=$P(LINE,"^",5)
.S NOD18=$P(LINE,"^",6,99)
.S IEN=+$O(^IBE(357.6,"B",$E(PKG,1,30),0))
.Q:IEN<1
.I $P($G(^IBE(357.6,IEN,0)),"^")=PKG D
..S ^IBE(357.6,IEN,18)=NOD18
..I $G(ENT)'="" S $P(^IBE(357.6,IEN,0),"^",2)=ENT
..I $G(RTN)'="" S $P(^IBE(357.6,IEN,0),"^",3)=RTN
..I $G(DYN)'="" S $P(^IBE(357.6,IEN,0),"^",14)=DYN
Q
;
UPDATE ;;
;;59^INPUT PROCEDURE CODE (CPT4)^^^^S IBDF("OTHER")="81^I '$P(^(0),U,4)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"CPT Procedure Code")
;;61^INPUT PROVIDER^PRVDR^IBDFN4^1^S IBDF("OTHER")="200^$$SCREEN^IBDFDE10(+Y)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Provider")
;;62^INPUT VISIT TYPE^^^^S IBDF("OTHER")="357.69^I '$P(^(0),U,4)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Visit Type (EM) Code")
;;69^INPUT DIAGNOSIS CODE (ICD9)^^^^S IBDF("OTHER")="80^I '$P(^(0),U,9)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Diagnosis Code")
;;74^PX INPUT PATIENT ACTIVE PROBLEM^DSELECT^GMPLENFM^1^D LIST^IBDFDE2(.IBDSEL,.IBDF,"Active Problem")
;;91^PX INPUT EDUCATION TOPICS^^^^S IBDF("OTHER")="9999999.09^I '$P(^(0),U,3)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Patient Education")
;;92^PX INPUT EXAMS^^^^S IBDF("OTHER")="9999999.15^I '$P(^(0),U,4)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Exam")
;;93^PX INPUT HEALTH FACTORS^^^^S IBDF("OTHER")="9999999.64^I '$P(^(0),U,10),$P(^(0),U,10)=""F"",'$P(^(0),U,11)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Health Factors")
;;94^PX INPUT IMMUNIZATION^^^^S IBDF("OTHER")="9999999.14^I '$P(^(0),U,7)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Immunizations")
;;97^PX INPUT SKIN TESTS^^^^S IBDF("OTHER")="9999999.28^I '$P(^(0),U,3)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Skin Tests")
;;99^PX INPUT VITALS^^^^D HNDPR^IBDFDE3(.IBDSEL,.IBDF)
;;103^GMP INPUT CLINIC COMMON PROBLEMS^^^^S IBDF("LEXICON")=1,IBDF("OTHER")="757.01^" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Diagnosis, Problem, or Term")
;;
;; -- Example of setting up a date/time prompt
;;95^PX INPUT CHECKOUT TIME^^^^S IBDF("ASKDATE")=1 D HNDPR^IBDFDE3(.IBDSEL,.IBDF) K IBDF("ASKDATE")
;;
;; -- Example of setting up a multiple choice field
;;100^PX INPUT VISIT CLASSIFICATION^^^^D MULT^IBDFDE4(.IBDSEL,.IBDF)
;;
IBDFDE5 ;ALB/AAS - AICS Manual Data Entry, Loader routine for 357.6 ; 19-APR-96
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**40**;APR 24, 1997
+2 ;
% GOTO ^IBDFDE
+1 ;
+2 ;
COMPLST ; -- procedure, compile form list arrays in ^tmp
+1 ; ^tmp("ibd-lText",$j,form,package interface,list,text,cnt,n)=entry number
+2 ; ^tmp("ibd-lCode",$j,form,package interface,list," "_code,cnt,n)= entry number
+3 ; ^tmp("ibd-lst",$j,form,package inteface,list)=display text^display code^input value^ optional caption^ optional term^selectable?
+4 ;
+5 NEW IBDI,FORM,PI,IEN,CNT,CH,CODE
+6 IF '$GET(IBDF("PI"))!('$GET(IBDF("IEN")))!('$GET(IBDFMIEN))
GOTO COMPQ
+7 SET PI=IBDF("PI")
SET IEN=IBDF("IEN")
SET FORM=IBDFMIEN
+8 ;
+9 ;K ^TMP("IBD-LST",$J,FORM,PI,IEN),^TMP("IBD-LTEXT",$J,FORM,PI,IEN),^TMP("IBD-LCODE",$J,FORM,PI,IEN)
+10 KILL ^TMP("IBD-LTEXT",$JOB,FORM,PI,IEN),^TMP("IBD-LCODE",$JOB,FORM,PI,IEN)
+11 ;
+12 ;M ^TMP("IBD-LST",$J,FORM,PI,IEN)=CHOICE
+13 KILL CHOICE
+14 ;
+15 ; -- Expand choices
+16 SET HDR=""
+17 SET IBDI=0
FOR
SET IBDI=$ORDER(^TMP("IBD-LST",$JOB,FORM,PI,IEN,IBDI))
IF 'IBDI
QUIT
SET CH=$GET(^(IBDI))
Begin DoDot:1
+18 IF $PIECE(CH,"^",7)=0
SET HDR=$PIECE(CH,"^")
QUIT
+19 IF $PIECE(CH,"^",8)=""
SET $PIECE(^TMP("IBD-LST",$JOB,FORM,PI,IEN,IBDI),"^",8)=HDR
+20 ;
+21 ; -- build array of text
+22 IF $PIECE(CH,"^",1)'=""
Begin DoDot:2
+23 IF '$DATA(^TMP("IBD-LTEXT",$JOB,FORM,PI,IEN,$EXTRACT($$UP^XLFSTR($PIECE(CH,"^",1)),1,80)))
SET ^TMP("IBD-LTEXT",$JOB,FORM,PI,IEN,$EXTRACT($$UP^XLFSTR($PIECE(CH,"^",1)),1,80),1)=IBDI
QUIT
+24 SET CNT=$ORDER(^TMP("IBD-LTEXT",$JOB,FORM,PI,IEN,$EXTRACT($$UP^XLFSTR($PIECE(CH,"^",1)),1,80),""),-1)
+25 SET ^TMP("IBD-LTEXT",$JOB,FORM,PI,IEN,$EXTRACT($$UP^XLFSTR($PIECE(CH,"^",1)),1,80),CNT+1)=IBDI
End DoDot:2
+26 ;
+27 ; -- build array of codes
+28 SET CODE=$SELECT($PIECE(CH,"^",2)'="":$PIECE(CH,"^",2),1:$PIECE(CH,"^",3))
IF CODE=""
QUIT
+29 IF '$DATA(^TMP("IBD-LCODE",$JOB,FORM,PI,IEN," "_CODE,1))
SET ^TMP("IBD-LCODE",$JOB,FORM,PI,IEN," "_CODE,1)=IBDI
QUIT
+30 SET CNT=$ORDER(^TMP("IBD-LCODE",$JOB,FORM,PI,IEN," "_CODE,""),-1)
SET ^TMP("IBD-LCODE",$JOB,FORM,PI,IEN," "_CODE,CNT+1)=IBDI
End DoDot:1
+31 ;
COMPQ QUIT
+1 ;
MDCOMP(FORM) ; -- compile form for manual data entry into ^xtmp
+1 ; -- ^xtmp("ibd"_form,0) := date ^ date
+2 ; ^xtmp("ibd"_form, "ibd-obj", n) := object listing for form
+3 ; ^xtmp("ibd"_form, "ibd-lst", pkg interface, list, n) := listing of each list
+4 ; ^xtmp("ibd"_form, "ibd-lst", pkg interface, list ,"code", " "_code, n) := code index
+5 ; ^xtmp("ibd"_form, "ibd-lst", pkg interface, list "text", text, n) := text index
+6 ;
+7 ; -- before converting to xtmp must resolve compile issues,
+8 ; such as when form is in use for data entry etc.
+9 ; need schema for locks...think about this
+10 ; remember to check old logic for changes
+11 ;
+12 NEW I,J,X,Y,NAM,IBDOBJ
+13 IF $GET(^IBE(357,+$GET(FORM),0))=""
GOTO MDCQ
+14 SET NAM="IBD"_FORM
+15 LOCK +^XTMP(NAM):10
IF '$TEST
WRITE !!,"form is in use, data entry compile failed",!
SET IBQUIT=1
GOTO MDCQ
+16 ; make sure ibdfde locks so doesn't kill when in use
KILL ^XTMP(NAM)
+17 SET ^XTMP(NAM,0)=$$FMADD^XLFDT(DT,90)_"^"_DT
+18 DO FRMLSTI^IBDFRPC(.IBDOBJ,FORM,"",1)
+19 MERGE ^XTMP(NAM,"IBD-OBJ")=IBDOBJ
+20 KILL IBDOBJ
+21 ;
+22 ; -- build entry for lists
+23 SET X=0
FOR
SET X=$ORDER(^XTMP(NAM,"IBD-OBJ",X))
IF 'X
QUIT
SET Y=^(X)
Begin DoDot:1
+24 ;dyanamic lists get compiled by ibdfde2 and then killed
IF $PIECE($GET(^IBE(357.6,+$PIECE(Y,"^",2),0)),"^",14)
QUIT
+25 IF $PIECE(Y,"^",5)="LIST"
DO MDCLIST(FORM,$PIECE(Y,"^",2),$PIECE(Y,"^",6))
End DoDot:1
+26 ;
MDCQ LOCK -^XTMP(NAM)
+1 QUIT
+2 ;
MDCLIST(FORM,PI,LIST) ; -- Compile one list
+1 NEW I,J,X,Y,IBDF,CH,CODE
+2 IF $GET(^IBE(357.6,+$GET(PI),0))=""!($GET(^IBE(357.2,+$GET(LIST),0))="")!($GET(^IBE(357,+$GET(FORM),0))="")
GOTO MDCLQ
+3 SET IBDF("PI")=PI
SET IBDF("IEN")=LIST
SET IBDF("TYPE")="LIST"
+4 KILL ^XTMP("IBD"_FORM,"IBD-LST",PI,LIST)
+5 DO OBJLST^IBDFRPC1(.CH,.IBDF)
+6 MERGE ^XTMP("IBD"_FORM,"IBD-LST",PI,LIST)=CH
+7 ;
+8 ; -- Expand choices
+9 SET HDR=""
+10 SET IBDI=0
FOR
SET IBDI=$ORDER(^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,IBDI))
IF 'IBDI
QUIT
SET CH=^(IBDI)
Begin DoDot:1
+11 IF $PIECE(CH,"^",7)=0
SET HDR=$PIECE(CH,"^")
QUIT
+12 IF $PIECE(CH,"^",8)=""
SET $PIECE(^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,I),"^",8)=HDR
+13 ;
+14 ; -- build array of text
+15 IF $PIECE(CH,"^",1)'=""
Begin DoDot:2
+16 IF '$DATA(^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"TEXT",$$UP^XLFSTR($PIECE(CH,"^",1))))
SET ^XTMP("IBD"_FORM,PI,LIST,"TEXT",$$UP^XLFSTR($PIECE(CH,"^",1)),1)=IBDI
QUIT
+17 SET CNT=$ORDER(^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"TEXT",$$UP^XLFSTR($PIECE(CH,"^",1)),""),-1)
+18 SET ^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"TEXT",$$UP^XLFSTR($PIECE(CH,"^",1)),CNT+1)=IBDI
End DoDot:2
+19 ;
+20 ; -- build array of codes
+21 SET CODE=$SELECT($PIECE(CH,"^",2)'="":$PIECE(CH,"^",2),1:$PIECE(CH,"^",3))
IF CODE=""
QUIT
+22 IF '$DATA(^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"CODE"," "_CODE,1))
SET ^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"CODE"," "_CODE,1)=IBDI
QUIT
+23 SET CNT=$ORDER(^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"CODE"," "_CODE,""),-1)
SET ^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"CODE"," "_CODE,CNT+1)=IBDI
+24 QUIT
End DoDot:1
+25 ;
MDCLQ QUIT
+1 ;
18 ; -- Post init for data entry patch
+1 DO 14
DO CLNTMP
DO XREF
DO PIDIM
DO PIUP
+2 QUIT
+3 ;
14 ;Populate the .14 FIELD IN FILE 357.96
+1 SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTRTN="DQ^IBDFDE5"
SET ZTDESC="IBD-Patch 2 populate 357.96;.14"
DO ^%ZTLOAD
+2 DO BMES^XPDUTL("Queing the Conversion to populate the .14 field (NO APPOINTMENT ENTRY) of file 357.96 ENCOUNTER FORM TRACKING......")
+3 QUIT
+4 ;
DQ ;
+1 NEW IBDFIFN,IBDFCLIN,IBDFAPPT,IBDFDFN
+2 SET IBDFIFN=0
+3 FOR
SET IBDFIFN=$ORDER(^IBD(357.96,IBDFIFN))
IF 'IBDFIFN
QUIT
SET IBDFNODE=$GET(^IBD(357.96,IBDFIFN,0))
SET IBDFDFN=$PIECE(IBDFNODE,"^",2)
SET IBDFAPPT=$PIECE(IBDFNODE,"^",3)
IF IBDFDFN
IF IBDFAPPT
Begin DoDot:1
+4 SET DIE="^IBD(357.96,"
SET DA=IBDFIFN
+5 IF $DATA(^DPT(+IBDFIFN,"S",IBDFAPPT))
SET DR=".14////0"
+6 IF '$TEST
SET DR=".14////1"
+7 DO ^DIE
KILL DA,DR,DIE
End DoDot:1
+8 ;W !!,"DONE"
+9 QUIT
CLNTMP ; -- kill tmp globals, on load, forces rebuild with updates
+1 KILL ^TMP("IBD-LST"),^TMP("IBD-OBJ")
+2 QUIT
+3 ;
XREF ;
+1 DO BMES^XPDUTL("Removing 'RECD' cross-reference on PRINTED FORM ID field")
+2 SET DA=0
+3 FOR
SET DA=$ORDER(^DD(357.96,.01,1,DA))
IF DA<1
QUIT
IF $GET(^(DA,0))="357.96^RECD^MUMPS"
SET DIK="^DD(357.96,.01,1,"
SET DA(2)=357.96
SET DA(1)=.01
DO ^DIK
KILL DIK
+4 ;
+5 DO BMES^XPDUTL("Removing 'RECD2' cross-reference on DATE/TIME RECEIVED IN VISTA field")
+6 SET DA=0
+7 FOR
SET DA=$ORDER(^DD(357.96,.06,1,DA))
IF DA<1
QUIT
IF $GET(^(DA,0))="357.96^RECD2^MUMPS"
SET DIK="^DD(357.96,.06,1,"
SET DA(2)=357.96
SET DA(1)=.06
DO ^DIK
KILL DIK
+8 ;
+9 DO BMES^XPDUTL("Removing 'RECD3' cross-reference on DATE/TIME PRINTED field")
+10 SET DA=0
+11 FOR
SET DA=$ORDER(^DD(357.96,.05,1,DA))
IF DA<1
QUIT
IF $GET(^(DA,0))="357.96^RECD3^MUMPS"
SET DIK="^DD(357.96,.05,1,"
SET DA(2)=357.96
SET DA(1)=.05
DO ^DIK
KILL DIK
+12 KILL DA
+13 KILL ^IBD(357.96,"RECD")
+14 QUIT
+15 ;
PIDIM ;
+1 DO BMES^XPDUTL("Updating PCE DIM OUTPUT TRANSFORM in file 357.6")
+2 NEW IBD,LINE,PKG,NOD14,IEN
+3 FOR IBD=1:1
SET LINE=$PIECE($TEXT(OUTTRANS+IBD),";;",2)
IF LINE=""
QUIT
Begin DoDot:1
+4 SET PKG=$PIECE(LINE,"^",2)
+5 SET NOD14=$PIECE(LINE,"^",3,99)
+6 SET IEN=+$ORDER(^IBE(357.6,"B",$EXTRACT(PKG,1,30),0))
+7 IF IEN<1
QUIT
+8 IF $PIECE($GET(^IBE(357.6,IEN,0)),"^")=PKG
SET ^IBE(357.6,IEN,14)=NOD14
End DoDot:1
+9 QUIT
OUTTRANS ;;
+1 ;;61^INPUT PROVIDER^S Y=$$DSPLYPRV^IBDFN9(Y)
+2 ;;62^INPUT VISIT TYPE^S Y=$$DSPLYCPT^IBDFN9(Y)
+3 ;;102^PX INPUT VISIT TYPE^S Y=$$DSPLYCPT^IBDFN9(Y)
+4 ;;
PIUP ;
+1 DO BMES^XPDUTL("Updating Package Interface File for Data Entry")
+2 NEW PKG,ENT,RTN,DYN,NODE18,IEN
+3 FOR IBD=1:1
SET LINE=$PIECE($TEXT(UPDATE+IBD),";;",2)
IF LINE=""
QUIT
Begin DoDot:1
+4 SET PKG=$PIECE(LINE,"^",2)
+5 SET ENT=$PIECE(LINE,"^",3)
+6 SET RTN=$PIECE(LINE,"^",4)
+7 SET DYN=$PIECE(LINE,"^",5)
+8 SET NOD18=$PIECE(LINE,"^",6,99)
+9 SET IEN=+$ORDER(^IBE(357.6,"B",$EXTRACT(PKG,1,30),0))
+10 IF IEN<1
QUIT
+11 IF $PIECE($GET(^IBE(357.6,IEN,0)),"^")=PKG
Begin DoDot:2
+12 SET ^IBE(357.6,IEN,18)=NOD18
+13 IF $GET(ENT)'=""
SET $PIECE(^IBE(357.6,IEN,0),"^",2)=ENT
+14 IF $GET(RTN)'=""
SET $PIECE(^IBE(357.6,IEN,0),"^",3)=RTN
+15 IF $GET(DYN)'=""
SET $PIECE(^IBE(357.6,IEN,0),"^",14)=DYN
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
UPDATE ;;
+1 ;;59^INPUT PROCEDURE CODE (CPT4)^^^^S IBDF("OTHER")="81^I '$P(^(0),U,4)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"CPT Procedure Code")
+2 ;;61^INPUT PROVIDER^PRVDR^IBDFN4^1^S IBDF("OTHER")="200^$$SCREEN^IBDFDE10(+Y)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Provider")
+3 ;;62^INPUT VISIT TYPE^^^^S IBDF("OTHER")="357.69^I '$P(^(0),U,4)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Visit Type (EM) Code")
+4 ;;69^INPUT DIAGNOSIS CODE (ICD9)^^^^S IBDF("OTHER")="80^I '$P(^(0),U,9)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Diagnosis Code")
+5 ;;74^PX INPUT PATIENT ACTIVE PROBLEM^DSELECT^GMPLENFM^1^D LIST^IBDFDE2(.IBDSEL,.IBDF,"Active Problem")
+6 ;;91^PX INPUT EDUCATION TOPICS^^^^S IBDF("OTHER")="9999999.09^I '$P(^(0),U,3)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Patient Education")
+7 ;;92^PX INPUT EXAMS^^^^S IBDF("OTHER")="9999999.15^I '$P(^(0),U,4)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Exam")
+8 ;;93^PX INPUT HEALTH FACTORS^^^^S IBDF("OTHER")="9999999.64^I '$P(^(0),U,10),$P(^(0),U,10)=""F"",'$P(^(0),U,11)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Health Factors")
+9 ;;94^PX INPUT IMMUNIZATION^^^^S IBDF("OTHER")="9999999.14^I '$P(^(0),U,7)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Immunizations")
+10 ;;97^PX INPUT SKIN TESTS^^^^S IBDF("OTHER")="9999999.28^I '$P(^(0),U,3)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Skin Tests")
+11 ;;99^PX INPUT VITALS^^^^D HNDPR^IBDFDE3(.IBDSEL,.IBDF)
+12 ;;103^GMP INPUT CLINIC COMMON PROBLEMS^^^^S IBDF("LEXICON")=1,IBDF("OTHER")="757.01^" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Diagnosis, Problem, or Term")
+13 ;;
+14 ;; -- Example of setting up a date/time prompt
+15 ;;95^PX INPUT CHECKOUT TIME^^^^S IBDF("ASKDATE")=1 D HNDPR^IBDFDE3(.IBDSEL,.IBDF) K IBDF("ASKDATE")
+16 ;;
+17 ;; -- Example of setting up a multiple choice field
+18 ;;100^PX INPUT VISIT CLASSIFICATION^^^^D MULT^IBDFDE4(.IBDSEL,.IBDF)
+19 ;;
