IBDFDE9 ;ALB/AAS - AICS Manual Data Entry, Report of inputs by form ; 31-MAY-96
;;3.0;AUTOMATED INFO COLLECTION SYS;**51**;APR 24, 1997
;
W !,?4,"** This option is OUT OF ORDER **" QUIT ;Code set Versioning
;
% N I,J,X,Y,DIR,DIRUT,DTOUT,DUOUT,IBDF,IBDFMIEN,IBDPAG,IBDPDT,IBDOJB,IBQUIT,QLFR,RULE
;
I '$D(DT) D DT^DICRW
D HOME^%ZIS
W !!,"Display Form Components for Data Entry",!!
;
STRT ; -- ask for form id
D END
S DIR("?")="Enter the Encounter Form Name you want to review."
S DIR(0)="PO^357:AEQM",DIR("A")="Select Encounter Form" D ^DIR K DIR,DA,DR,DIC
I $D(DIRUT) G END
S IBDFMIEN=+Y
;
; -- Ask Device
S %ZIS="MQ" D ^%ZIS I POP G STRTQ
; -- queue if selected
I $D(IO("Q")) S ZTSAVE("IBD*")="",ZTRTN="DQ^IBDFDE9",ZTDESC="IBD - Print form components" D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued Task="_ZTSK,1:"Request Canceled") D HOME^%ZIS W !! G STRT
U IO
S X="IOINHI;IOINORM" D ENDR^%ZISS
D DQ
;
STRTQ G:$G(IBQUIT) END D PAUSE^IBDFDE
G STRT
;
DQ ; -- entry point to list contents of one form,
; Input IBDFMIEN := pointer to Encounter Form (357)
;
S IBQUIT=0
S IBDPAG=0
S IBDPDT=$$FMTE^XLFDT($$NOW^XLFDT)
D HDR
;
I '$D(^TMP("IBD-OBJ",$J,IBDFMIEN,0)) D FRMLSTI^IBDFRPC("^TMP(""IBD-OBJ"",$J,IBDFMIEN)",IBDFMIEN,"",1)
D LISTOB
Q
;
LISTOB ; -- list items available for input on a form
W !,"CHECKOUT INTERVIEW",?27,"",?45,"As Required",!
S I=0 F S I=$O(^TMP("IBD-OBJ",$J,IBDFMIEN,I)) Q:I=""!(IBQUIT) D
.I $E(IOST,1,2)="C-",$Y>(IOSL-5) D HDR Q:IBQUIT
.S IBDOBJ=$G(^TMP("IBD-OBJ",$J,IBDFMIEN,I))
.Q:'$P(IBDOBJ,"^",8)
.S IBDF("PI")=+$P(IBDOBJ,"^",2),IBDF("TYPE")=$P(IBDOBJ,"^",5)
.S IBDF("IEN")=+$P(IBDOBJ,"^",6),IBDF("VITAL")=$P(IBDOBJ,"^",7)
.Q:IBDF("IEN")<1!(IBDF("PI")<1)
.S RTN=$G(^IBE(357.6,IBDF("PI"),18)) Q:RTN=""
.S Y=$S($P(IBDOBJ,"^",7)="":$P(IBDOBJ,"^"),1:$P(IBDOBJ,"^",7))
.I Y["INPUT " S Y=$P(Y,"INPUT ",2)
.W !,$E(Y,1,25),?27,$S(IBDF("TYPE")="HP":"Hand Print",IBDF("TYPE")="LIST":"Selection List",1:"Multiple Choice")
.;
.S IBDF("DFN")=$O(^DPT(0)),IBDF("CLINIC")=$O(^SC(0)),IBDF("RULE-ONLY")=1
.S RULE(0)=$G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN")))
.I RULE(0)="" D OBJLST^IBDFRPC1(.RULE,.IBDF)
.D RULES(.RULE)
.W !
W !
Q
;
HDR ; -- print patient header
S IBDPAG=IBDPAG+1
I $E(IOST,1,2)="C-",$Y>1,IBDPAG>1 D PAUSE^IBDFDE Q:IBQUIT
I $E(IOST,1,2)="C-"!(IBDPAG>1) W @IOF
W !,"Form Components Available for Data Entry",?IOM-32,IBDPDT," PAGE: ",IBDPAG
W !,"COMPONENT",?27,"TYPE",?45,"RULE",?60,"QUALIFIER"
W !,$TR($J(" ",IOM)," ","-")
W !," Form Name: ",$E($P($G(^IBE(357,+IBDFMIEN,0)),"^"),1,25)
W !," Form Status: ",$S(+$P($G(^IBE(357,+IBDFMIEN,0)),"^",5):"Compiled",1:"Uncompiled"),!
Q
;
END I $D(ZTQUEUED) S ZTREQ="@" Q
K I,J,X,Y,DA,DR,DIC,DIE,DIR,DTOUT,DUOUT,DIRUT,IBDSEL,CHOICE,TEXT,TEXTU,RESULT,IBDPI,IBDCO,IBDF,IBDPAG,ZTSK
K ^TMP("IBD-OBJ",$J)
D ^%ZISC
Q
;
RULES(RULE) ; -- look at zero node, find qualifiers and selection rule
N I,QLFR,DQR
S RULE=$P(RULE(0),"^",3),QLFR=""
I $P(RULE(0),"^",4) W ?45,"Data Entry Not allowed",!,?45,"Marking areas not Bubbles" Q
F I=1:1 S ROW=$P(RULE,"::",I) Q:ROW="" S QLFR(I)=$P(ROW,";;",1),RULE(I)=$P(ROW,";;",2) D
.W:I>1 !
.;
.I IBDF("VITAL")="" W ?45,$P("Any Number^Exactly One^At Most One^At Least One","^",(RULE(I)+1))
.E W ?45,"Optional"
.;
.I IBDF("VITAL")'="",QLFR(I)[":" S QLFR(I)=$P(QLFR(I),":") ;strip ":"
.W ?60,$E(QLFR(I),1,20)
.I QLFR(I)="",$P($G(^IBE(357.6,+$G(IBDF("PI")),0)),"^",19) W ?60,$G(IOINHI),"Required/Missing",$G(IOINORM)
.I QLFR(I)="PRIMARY" D
..;S RULE(I)=$S(RULE(I)=3:1,RULE(I)=0:2,1:RULE(I))
S RULE=I-1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFDE9 3697 printed Nov 22, 2024@18:02:37 Page 2
IBDFDE9 ;ALB/AAS - AICS Manual Data Entry, Report of inputs by form ; 31-MAY-96
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**51**;APR 24, 1997
+2 ;
+3 ;Code set Versioning
WRITE !,?4,"** This option is OUT OF ORDER **"
QUIT
+4 ;
% NEW I,J,X,Y,DIR,DIRUT,DTOUT,DUOUT,IBDF,IBDFMIEN,IBDPAG,IBDPDT,IBDOJB,IBQUIT,QLFR,RULE
+1 ;
+2 IF '$DATA(DT)
DO DT^DICRW
+3 DO HOME^%ZIS
+4 WRITE !!,"Display Form Components for Data Entry",!!
+5 ;
STRT ; -- ask for form id
+1 DO END
+2 SET DIR("?")="Enter the Encounter Form Name you want to review."
+3 SET DIR(0)="PO^357:AEQM"
SET DIR("A")="Select Encounter Form"
DO ^DIR
KILL DIR,DA,DR,DIC
+4 IF $DATA(DIRUT)
GOTO END
+5 SET IBDFMIEN=+Y
+6 ;
+7 ; -- Ask Device
+8 SET %ZIS="MQ"
DO ^%ZIS
IF POP
GOTO STRTQ
+9 ; -- queue if selected
+10 IF $DATA(IO("Q"))
SET ZTSAVE("IBD*")=""
SET ZTRTN="DQ^IBDFDE9"
SET ZTDESC="IBD - Print form components"
DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"Request Queued Task="_ZTSK,1:"Request Canceled")
DO HOME^%ZIS
WRITE !!
GOTO STRT
+11 USE IO
+12 SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
+13 DO DQ
+14 ;
STRTQ if $GET(IBQUIT)
GOTO END
DO PAUSE^IBDFDE
+1 GOTO STRT
+2 ;
DQ ; -- entry point to list contents of one form,
+1 ; Input IBDFMIEN := pointer to Encounter Form (357)
+2 ;
+3 SET IBQUIT=0
+4 SET IBDPAG=0
+5 SET IBDPDT=$$FMTE^XLFDT($$NOW^XLFDT)
+6 DO HDR
+7 ;
+8 IF '$DATA(^TMP("IBD-OBJ",$JOB,IBDFMIEN,0))
DO FRMLSTI^IBDFRPC("^TMP(""IBD-OBJ"",$J,IBDFMIEN)",IBDFMIEN,"",1)
+9 DO LISTOB
+10 QUIT
+11 ;
LISTOB ; -- list items available for input on a form
+1 WRITE !,"CHECKOUT INTERVIEW",?27,"",?45,"As Required",!
+2 SET I=0
FOR
SET I=$ORDER(^TMP("IBD-OBJ",$JOB,IBDFMIEN,I))
if I=""!(IBQUIT)
QUIT
Begin DoDot:1
+3 IF $EXTRACT(IOST,1,2)="C-"
IF $Y>(IOSL-5)
DO HDR
if IBQUIT
QUIT
+4 SET IBDOBJ=$GET(^TMP("IBD-OBJ",$JOB,IBDFMIEN,I))
+5 if '$PIECE(IBDOBJ,"^",8)
QUIT
+6 SET IBDF("PI")=+$PIECE(IBDOBJ,"^",2)
SET IBDF("TYPE")=$PIECE(IBDOBJ,"^",5)
+7 SET IBDF("IEN")=+$PIECE(IBDOBJ,"^",6)
SET IBDF("VITAL")=$PIECE(IBDOBJ,"^",7)
+8 if IBDF("IEN")<1!(IBDF("PI")<1)
QUIT
+9 SET RTN=$GET(^IBE(357.6,IBDF("PI"),18))
if RTN=""
QUIT
+10 SET Y=$SELECT($PIECE(IBDOBJ,"^",7)="":$PIECE(IBDOBJ,"^"),1:$PIECE(IBDOBJ,"^",7))
+11 IF Y["INPUT "
SET Y=$PIECE(Y,"INPUT ",2)
+12 WRITE !,$EXTRACT(Y,1,25),?27,$SELECT(IBDF("TYPE")="HP":"Hand Print",IBDF("TYPE")="LIST":"Selection List",1:"Multiple Choice")
+13 ;
+14 SET IBDF("DFN")=$ORDER(^DPT(0))
SET IBDF("CLINIC")=$ORDER(^SC(0))
SET IBDF("RULE-ONLY")=1
+15 SET RULE(0)=$GET(^TMP("IBD-LST",$JOB,IBDFMIEN,IBDF("PI"),IBDF("IEN")))
+16 IF RULE(0)=""
DO OBJLST^IBDFRPC1(.RULE,.IBDF)
+17 DO RULES(.RULE)
+18 WRITE !
End DoDot:1
+19 WRITE !
+20 QUIT
+21 ;
HDR ; -- print patient header
+1 SET IBDPAG=IBDPAG+1
+2 IF $EXTRACT(IOST,1,2)="C-"
IF $Y>1
IF IBDPAG>1
DO PAUSE^IBDFDE
if IBQUIT
QUIT
+3 IF $EXTRACT(IOST,1,2)="C-"!(IBDPAG>1)
WRITE @IOF
+4 WRITE !,"Form Components Available for Data Entry",?IOM-32,IBDPDT," PAGE: ",IBDPAG
+5 WRITE !,"COMPONENT",?27,"TYPE",?45,"RULE",?60,"QUALIFIER"
+6 WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-")
+7 WRITE !," Form Name: ",$EXTRACT($PIECE($GET(^IBE(357,+IBDFMIEN,0)),"^"),1,25)
+8 WRITE !," Form Status: ",$SELECT(+$PIECE($GET(^IBE(357,+IBDFMIEN,0)),"^",5):"Compiled",1:"Uncompiled"),!
+9 QUIT
+10 ;
END IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+1 KILL I,J,X,Y,DA,DR,DIC,DIE,DIR,DTOUT,DUOUT,DIRUT,IBDSEL,CHOICE,TEXT,TEXTU,RESULT,IBDPI,IBDCO,IBDF,IBDPAG,ZTSK
+2 KILL ^TMP("IBD-OBJ",$JOB)
+3 DO ^%ZISC
+4 QUIT
+5 ;
RULES(RULE) ; -- look at zero node, find qualifiers and selection rule
+1 NEW I,QLFR,DQR
+2 SET RULE=$PIECE(RULE(0),"^",3)
SET QLFR=""
+3 IF $PIECE(RULE(0),"^",4)
WRITE ?45,"Data Entry Not allowed",!,?45,"Marking areas not Bubbles"
QUIT
+4 FOR I=1:1
SET ROW=$PIECE(RULE,"::",I)
if ROW=""
QUIT
SET QLFR(I)=$PIECE(ROW,";;",1)
SET RULE(I)=$PIECE(ROW,";;",2)
Begin DoDot:1
+5 if I>1
WRITE !
+6 ;
+7 IF IBDF("VITAL")=""
WRITE ?45,$PIECE("Any Number^Exactly One^At Most One^At Least One","^",(RULE(I)+1))
+8 IF '$TEST
WRITE ?45,"Optional"
+9 ;
+10 ;strip ":"
IF IBDF("VITAL")'=""
IF QLFR(I)[":"
SET QLFR(I)=$PIECE(QLFR(I),":")
+11 WRITE ?60,$EXTRACT(QLFR(I),1,20)
+12 IF QLFR(I)=""
IF $PIECE($GET(^IBE(357.6,+$GET(IBDF("PI")),0)),"^",19)
WRITE ?60,$GET(IOINHI),"Required/Missing",$GET(IOINORM)
+13 IF QLFR(I)="PRIMARY"
Begin DoDot:2
+14 ;S RULE(I)=$S(RULE(I)=3:1,RULE(I)=0:2,1:RULE(I))
End DoDot:2
End DoDot:1
+15 SET RULE=I-1
+16 QUIT
