IBDFC2B ;ALB/CJM - ENCOUNTER FORM - converts a form for scanning ;MAR 3, 1995
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
ADDOTHER ;add space to the list to write in other
N NODE
S NODE=$G(^IBE(357.2,IBLIST,0))
I NODE]"",$P(NODE,"^",16)="" S $P(NODE,"^",16)=1,$P(NODE,"^",17)=3,$P(NODE,"^",18)=2 S ^IBE(357.2,IBLIST,0)=NODE
Q
;
CKVALUES ;make sure the internal value to be passed matches the value displayed and is an active code
;
Q:'IBLIST("INPUT_RTN")
N SUBCOL,I,SLCTN,IEN,TEXT,CODE,NODE
;
;find the subcolumn with the code
S SUBCOL=0 F I=1:1:8 I $G(IBLIST("SCPIECE",I))=1,$G(IBLIST("SCTYPE",I))=1 S SUBCOL=I
;
;check that the display of the code matches its id and that it's active
S SLCTN=0 F S SLCTN=$O(^IBE(357.3,"C",IBLIST,SLCTN)) Q:'SLCTN D
.S NODE=$G(^IBE(357.3,SLCTN,0))
.;
.;check if place holder
.Q:$P(NODE,"^",2)
.;
.S CODE=$P(NODE,"^")
.Q:CODE=""
.;
.;check for inactive codes
.I '$$CKACTIVE(CODE,IBLIST("RTN")) D
..S TEXT=$$DISPLAY(SLCTN)
..D WARNING^IBDFC2("IN THE SELECTION LIST '"_IBLIST("NAME")_"' THE ENTRY="_TEXT_" IS AN INACTIVE CODE")
.;
.;check for displayed codes that don't match their id stored on piece 1
.Q:'SUBCOL
.S IEN=$O(^IBE(357.3,SLCTN,1,"B",SUBCOL,0))
.Q:'IEN
.S TEXT=$P($G(^IBE(357.3,SLCTN,1,IEN,0)),"^",2)
.Q:'$L(TEXT)
.I CODE'=TEXT D
..; -- codes doesn't match text and autochange= yes
..I $G(IBDASK("AUTOCHG")),$$CKACTIVE(TEXT,IBLIST("RTN")) D Q
...; use fm to update data and x-refs S $P(^IBE(357.3,SLCTN,0),"^")=TEXT
...S DIE=357.3,DR=".01////^S X=TEXT",DA=SLCTN D ^DIE K DIE,DA,DR
...D WARNING^IBDFC2("In the Selection List '"_IBLIST("NAME")_"' the Code="_CODE_" was automatically update to match the text="_TEXT)
...Q
..D WARNING^IBDFC2("IN THE SELECTION LIST '"_IBLIST("NAME")_"' THE CODE="_TEXT_" IS DISPLAYED BUT THE CODE="_CODE_" WILL BE TRANSMITTED") Q
Q
;
CHKVISIT ;should the selection list use the new Package Interface for Type of Visit?
;
I ($$UP^XLFSTR(IBLIST("NAME"))["VISIT")!($$UP^XLFSTR(IBBLK("NAME"))["VISIT"),IBLIST("RTN") I $P($G(^IBE(357.6,IBLIST("RTN"),0)),"^")["SELECT CPT PROCEDURE" D
.N SLCTN,CODE,PI,CHANGE
.S PI=$O(^IBE(357.6,"B","DG SELECT VISIT TYPE CPT PROCE",0))
.Q:'PI
.S CHANGE=1,SLCTN=0 F S SLCTN=$O(^IBE(357.3,"C",IBLIST,SLCTN)) Q:'SLCTN S CODE=$P($G(^IBE(357.3,SLCTN,0)),"^") I CODE I '$D(^IBE(357.69,CODE,0)) S CHANGE=0 Q
.;change the list to visit type
.I CHANGE D
..N CNT,SC,NODE,SUB S (CNT,SC)=""
..;change the package interface to type of visit
..S $P(^IBE(357.2,IBLIST,0),"^",11)=PI
..;set the selection rule to exactly one as long as there is only one marking subcolumn
..F S SC=$O(^IBE(357.2,IBLIST,2,SC)) Q:'SC S NODE=$G(^IBE(357.2,IBLIST,2,SC,0)) I $P(NODE,"^",4)=2 S CNT=CNT+1,SUB=SC
..I CNT=1,$P(NODE,"^",10)="" S $P(^IBE(357.2,IBLIST,2,SUB,0),"^",10)=1
.;
.I 'CHANGE,IBLIST("NAME")["VISIT",IBLIST("NAME")["TYPE" D WARNING^IBDFC2("THE BLOCK '"_IBBLK("NAME")_"' HAS A LIST FOR CPT PROCEDURES THAT PERHAPS SHOULD BE REPLACED WITH VISIT TYPE")
Q
;
CKACTIVE(X,PI) ;returns 1 if the X=an active code, 0 otherwise
Q:'PI 1
X $G(^IBE(357.6,PI,11))
Q $D(X)
;
DISPLAY(SLCTN) ;returns selection display
N SC,SCDA,VAL,RET,W,NODE
;W - an array cotaining the widths of the subcolumns that contain text
S NODE=$G(^IBE(357.3,SLCTN,0))
S RET=" ",(VAL,SC)=""
F SC=1:1:8 S SCDA=$O(^IBE(357.3,SLCTN,1,"B",SC,"")) D
.I $G(IBLIST("SCTYPE",SC))=1 S W(SC)=IBLIST("SCW",SC)*(1+IBLIST("BTWN"))
.S:$G(W(SC)) VAL=$$PADRIGHT^IBDFU($S(SCDA:$P($G(^IBE(357.3,SLCTN,1,SCDA,0)),"^",2),1:""),W(SC))
.S:VAL'="" RET=RET_" "_VAL
.S VAL=""
Q RET
;
ASKOTH() ; Function
; -- ask if want to add other hand print field automatically
; Returns 1 if yes, 0 if no, or -1 if uparrow
;
N X,Y,ANS,DIR
W !
S ANS=-1
S DIR("?")="Answer YES if you want to automatically add 1 hand print field to each selection list. If you answer NO nothing will be added."
S DIR("?",1)=" Hand print fields can be automatically added to your form"
S DIR("?",2)=" if you wish. If there isn't suffient room in the block"
S DIR("?",3)=" or on the form them adding the hand print field will cause"
S DIR("?",4)=" part of the list to disappear."
S DIR("?",5)=" "
S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Automatically Add 'Other' Hand Print Fields"
D ^DIR
I $D(DIRUT) G ASKOTHQ
S ANS=Y
ASKOTHQ Q ANS
;
ASKAUTO() ; Function
; -- ask if want to automatically update codes
; Returns 1 if yes, 0 if no, or -1 if uparrow
;
N X,Y,ANS,DIR
W !
S ANS=-1
S DIR("?")="Answer YES if you want codes in the selection lists that will be transmitted to PCE to automatically be updated to match the displayed codes. If you answer No, warnings will be generated but the codes will not be updated."
S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Automatically update codes to be transmitted"
D ^DIR
I $D(DIRUT) G ASKAUTQ
S ANS=Y
ASKAUTQ Q ANS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFC2B 4990 printed Oct 16, 2024@18:52:48 Page 2
IBDFC2B ;ALB/CJM - ENCOUNTER FORM - converts a form for scanning ;MAR 3, 1995
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
ADDOTHER ;add space to the list to write in other
+1 NEW NODE
+2 SET NODE=$GET(^IBE(357.2,IBLIST,0))
+3 IF NODE]""
IF $PIECE(NODE,"^",16)=""
SET $PIECE(NODE,"^",16)=1
SET $PIECE(NODE,"^",17)=3
SET $PIECE(NODE,"^",18)=2
SET ^IBE(357.2,IBLIST,0)=NODE
+4 QUIT
+5 ;
CKVALUES ;make sure the internal value to be passed matches the value displayed and is an active code
+1 ;
+2 if 'IBLIST("INPUT_RTN")
QUIT
+3 NEW SUBCOL,I,SLCTN,IEN,TEXT,CODE,NODE
+4 ;
+5 ;find the subcolumn with the code
+6 SET SUBCOL=0
FOR I=1:1:8
IF $GET(IBLIST("SCPIECE",I))=1
IF $GET(IBLIST("SCTYPE",I))=1
SET SUBCOL=I
+7 ;
+8 ;check that the display of the code matches its id and that it's active
+9 SET SLCTN=0
FOR
SET SLCTN=$ORDER(^IBE(357.3,"C",IBLIST,SLCTN))
if 'SLCTN
QUIT
Begin DoDot:1
+10 SET NODE=$GET(^IBE(357.3,SLCTN,0))
+11 ;
+12 ;check if place holder
+13 if $PIECE(NODE,"^",2)
QUIT
+14 ;
+15 SET CODE=$PIECE(NODE,"^")
+16 if CODE=""
QUIT
+17 ;
+18 ;check for inactive codes
+19 IF '$$CKACTIVE(CODE,IBLIST("RTN"))
Begin DoDot:2
+20 SET TEXT=$$DISPLAY(SLCTN)
+21 DO WARNING^IBDFC2("IN THE SELECTION LIST '"_IBLIST("NAME")_"' THE ENTRY="_TEXT_" IS AN INACTIVE CODE")
End DoDot:2
+22 ;
+23 ;check for displayed codes that don't match their id stored on piece 1
+24 if 'SUBCOL
QUIT
+25 SET IEN=$ORDER(^IBE(357.3,SLCTN,1,"B",SUBCOL,0))
+26 if 'IEN
QUIT
+27 SET TEXT=$PIECE($GET(^IBE(357.3,SLCTN,1,IEN,0)),"^",2)
+28 if '$LENGTH(TEXT)
QUIT
+29 IF CODE'=TEXT
Begin DoDot:2
+30 ; -- codes doesn't match text and autochange= yes
+31 IF $GET(IBDASK("AUTOCHG"))
IF $$CKACTIVE(TEXT,IBLIST("RTN"))
Begin DoDot:3
+32 ; use fm to update data and x-refs S $P(^IBE(357.3,SLCTN,0),"^")=TEXT
+33 SET DIE=357.3
SET DR=".01////^S X=TEXT"
SET DA=SLCTN
DO ^DIE
KILL DIE,DA,DR
+34 DO WARNING^IBDFC2("In the Selection List '"_IBLIST("NAME")_"' the Code="_CODE_" was automatically update to match the text="_TEXT)
+35 QUIT
End DoDot:3
QUIT
+36 DO WARNING^IBDFC2("IN THE SELECTION LIST '"_IBLIST("NAME")_"' THE CODE="_TEXT_" IS DISPLAYED BUT THE CODE="_CODE_" WILL BE TRANSMITTED")
QUIT
End DoDot:2
End DoDot:1
+37 QUIT
+38 ;
CHKVISIT ;should the selection list use the new Package Interface for Type of Visit?
+1 ;
+2 IF ($$UP^XLFSTR(IBLIST("NAME"))["VISIT")!($$UP^XLFSTR(IBBLK("NAME"))["VISIT")
IF IBLIST("RTN")
IF $PIECE($GET(^IBE(357.6,IBLIST("RTN"),0)),"^")["SELECT CPT PROCEDURE"
Begin DoDot:1
+3 NEW SLCTN,CODE,PI,CHANGE
+4 SET PI=$ORDER(^IBE(357.6,"B","DG SELECT VISIT TYPE CPT PROCE",0))
+5 if 'PI
QUIT
+6 SET CHANGE=1
SET SLCTN=0
FOR
SET SLCTN=$ORDER(^IBE(357.3,"C",IBLIST,SLCTN))
if 'SLCTN
QUIT
SET CODE=$PIECE($GET(^IBE(357.3,SLCTN,0)),"^")
IF CODE
IF '$DATA(^IBE(357.69,CODE,0))
SET CHANGE=0
QUIT
+7 ;change the list to visit type
+8 IF CHANGE
Begin DoDot:2
+9 NEW CNT,SC,NODE,SUB
SET (CNT,SC)=""
+10 ;change the package interface to type of visit
+11 SET $PIECE(^IBE(357.2,IBLIST,0),"^",11)=PI
+12 ;set the selection rule to exactly one as long as there is only one marking subcolumn
+13 FOR
SET SC=$ORDER(^IBE(357.2,IBLIST,2,SC))
if 'SC
QUIT
SET NODE=$GET(^IBE(357.2,IBLIST,2,SC,0))
IF $PIECE(NODE,"^",4)=2
SET CNT=CNT+1
SET SUB=SC
+14 IF CNT=1
IF $PIECE(NODE,"^",10)=""
SET $PIECE(^IBE(357.2,IBLIST,2,SUB,0),"^",10)=1
End DoDot:2
+15 ;
+16 IF 'CHANGE
IF IBLIST("NAME")["VISIT"
IF IBLIST("NAME")["TYPE"
DO WARNING^IBDFC2("THE BLOCK '"_IBBLK("NAME")_"' HAS A LIST FOR CPT PROCEDURES THAT PERHAPS SHOULD BE REPLACED WITH VISIT TYPE")
End DoDot:1
+17 QUIT
+18 ;
CKACTIVE(X,PI) ;returns 1 if the X=an active code, 0 otherwise
+1 if 'PI
QUIT 1
+2 XECUTE $GET(^IBE(357.6,PI,11))
+3 QUIT $DATA(X)
+4 ;
DISPLAY(SLCTN) ;returns selection display
+1 NEW SC,SCDA,VAL,RET,W,NODE
+2 ;W - an array cotaining the widths of the subcolumns that contain text
+3 SET NODE=$GET(^IBE(357.3,SLCTN,0))
+4 SET RET=" "
SET (VAL,SC)=""
+5 FOR SC=1:1:8
SET SCDA=$ORDER(^IBE(357.3,SLCTN,1,"B",SC,""))
Begin DoDot:1
+6 IF $GET(IBLIST("SCTYPE",SC))=1
SET W(SC)=IBLIST("SCW",SC)*(1+IBLIST("BTWN"))
+7 if $GET(W(SC))
SET VAL=$$PADRIGHT^IBDFU($SELECT(SCDA:$PIECE($GET(^IBE(357.3,SLCTN,1,SCDA,0)),"^",2),1:""),W(SC))
+8 if VAL'=""
SET RET=RET_" "_VAL
+9 SET VAL=""
End DoDot:1
+10 QUIT RET
+11 ;
ASKOTH() ; Function
+1 ; -- ask if want to add other hand print field automatically
+2 ; Returns 1 if yes, 0 if no, or -1 if uparrow
+3 ;
+4 NEW X,Y,ANS,DIR
+5 WRITE !
+6 SET ANS=-1
+7 SET DIR("?")="Answer YES if you want to automatically add 1 hand print field to each selection list. If you answer NO nothing will be added."
+8 SET DIR("?",1)=" Hand print fields can be automatically added to your form"
+9 SET DIR("?",2)=" if you wish. If there isn't suffient room in the block"
+10 SET DIR("?",3)=" or on the form them adding the hand print field will cause"
+11 SET DIR("?",4)=" part of the list to disappear."
+12 SET DIR("?",5)=" "
+13 SET DIR(0)="Y"
SET DIR("B")="NO"
+14 SET DIR("A")="Automatically Add 'Other' Hand Print Fields"
+15 DO ^DIR
+16 IF $DATA(DIRUT)
GOTO ASKOTHQ
+17 SET ANS=Y
ASKOTHQ QUIT ANS
+1 ;
ASKAUTO() ; Function
+1 ; -- ask if want to automatically update codes
+2 ; Returns 1 if yes, 0 if no, or -1 if uparrow
+3 ;
+4 NEW X,Y,ANS,DIR
+5 WRITE !
+6 SET ANS=-1
+7 SET DIR("?")="Answer YES if you want codes in the selection lists that will be transmitted to PCE to automatically be updated to match the displayed codes. If you answer No, warnings will be generated but the codes will not be updated."
+8 SET DIR(0)="Y"
SET DIR("B")="NO"
+9 SET DIR("A")="Automatically update codes to be transmitted"
+10 DO ^DIR
+11 IF $DATA(DIRUT)
GOTO ASKAUTQ
+12 SET ANS=Y
ASKAUTQ QUIT ANS
