PXBGCPT4 ;ISL/JVS,ESW - DOUBLE ?? GATHERING OF FORM PROCEDURES ; 5/7/03 3:35pm
;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,43,108,121**;Aug 12, 1996
;
;
;
W !,"THIS IS NOT AN ENTRY POINT" Q
;
;
DOUBLE1(FROM) ;--Entry point
;
NEW ;
;
N FILE,FIELD,TITLE,HEADING,SUB,NAME,START,SCREEN,OK,INDEX,CYCLE
N TOTAL,PRV,CNT,PXBPMT,CODE,SUB2,SUBM,MODSTR,CNUM,MNUM,CONT,QT,PXMDIEN
;---SETUP VARIABLES
S BACK="",INDEX=""
S START=DATA,(CONT,SUB,SUB2,SUBM)=0
;
START1 ;--RECYCLE POINT
S TITLE="- - F O R M P R O C E D U R E S - -"
;
D GETLST^IBDF18A(CLINIC,$P($T(CPT^PXBAICS),";;",2),"PXBPMT",,,1,IDATE)
;
S TOTAL=PXBPMT(0)
I PXBPMT(0)>0 D
.S (SUB,CNT)=""
.F S SUB=$O(PXBPMT(SUB)) Q:SUB="" D
..S CODE=$P(PXBPMT(SUB),U)
..I '(CODE?5N!(CODE?1A4N)!(CODE?4N1A)) Q ;PX*1.0*108
..;I $P($G(^ICPT($O(^ICPT("B",CODE,0)),0)),U,4) Q
..I '$P($$CPT^ICPTCOD(CODE,IDATE),U,7) Q
..S NAME=$P(PXBPMT(SUB),U,2)
..S CNT=CNT+1
..S ^TMP("PXBTOTAL",$J,"DILIST","ID",CNT,.01)=CODE
..S ^TMP("PXBTOTAL",$J,"DILIST","ID",CNT,2)=NAME
..S SUBM=0
..F S SUBM=$O(PXBPMT(SUB,"MODIFIER",SUBM)) Q:SUBM="" D
...S PXMDIEN=+$$MODP^ICPTMOD(CODE,PXBPMT(SUB,"MODIFIER",SUBM),"E",IDATE)
...S MODSTR=$$MOD^ICPTMOD(PXMDIEN,"I",IDATE)
...I +MODSTR>0,$P(MODSTR,U,7) D
....S ^TMP("PXBTOTAL",$J,"DILIST","ID",CNT,"MODIFIER",SUBM)=$P(MODSTR,U,2)_U_$P(MODSTR,U,3)
I $D(CNT) S TOTAL=CNT
;
;--DISPLAY IF NO MATCH FOUND
I TOTAL=0 W IOCUU,IOCUU,!,IOELEOL D
.;D LOC,HEAD
.D LOC W !
.S RESULTS="NO PROCEDURE BLOCKS EXIST FOR AN ENCOUNTER FORM"
.W !!!,?(IOM-$L(RESULTS))\2,RESULTS
.D HELP1^PXBUTL1("CON")
.R OK:DTIME
I TOTAL=0 S TOTAL="^C" Q TOTAL
;
;
;----DISPLAY LIST TO THE SCREEN
S HEADING="W !,""ITEM"",?6,""CODE"",?13,""DESCRIPTION "",IOINHI,TOTAL,"" ENTRIES"",IOINLOW"
;
LIST ;-DISPLAY LIST TO THE SCREEN
;D LOC,HEAD
D LOC W !
X HEADING
S SUB=$P(CONT,U)-1
S (QT,CNUM,MNUM)=0
F S SUB=$O(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB)) Q:SUB'>0 S SUB2=SUB2+1 D Q:QT
.S CNUM=CNUM+1
.I CNUM+MNUM=11 S CONT=SUB_U_0,QT=1 Q
.S CODE=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,.01))
.S NAME=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,2))
.W !,SUB,?6,CODE,?13,NAME
.S SUBM=$P(CONT,U,2)-1
.S:$P(CONT,U,2)>0 $P(CONT,U,2)=0
.F S SUBM=$O(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,"MODIFIER",SUBM)) Q:SUBM="" D Q:QT
..S MNUM=MNUM+1
..I MNUM+CNUM=11 S CONT=SUB_U_SUBM,QT=1 Q
..S MODSTR=^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,"MODIFIER",SUBM)
..W !?6,"CPT Modifier:",?21,$P(MODSTR,U),?25,$P(MODSTR,U,2)
;
;----If There is only one selection go to proper prompting
I TOTAL=1 G PRMPT2
;
PRMPT ;---WRITE PROMPT HERE
D WIN17^PXBCC(PXBCNT)
D LOC^PXBCC(15,1)
W !
I SUB>0 W !,"Enter '^' to quit"
E I TOTAL>10 W !," END OF LIST"
I SUB>0 S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "
E S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to exit: "
S DIR("?")="Enter ITEM 'No' to select , '^' to quit"
S DIR(0)="N,A,O^0:"_SUB2_":0^I X'?.1""^"".N K X"
D ^DIR
I X="",SUB>0 G LIST
I X="",SUB'>0 S X="^"
I $G(DIRUT) K DIRUT S VAL="^C" G EXITNEW
VAL ;-----Set the VAL equal to the value
S VAL=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,2))_"^"_$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,.01))
S (MODSTR,SUBM)=""
F S SUBM=$O(^TMP("PXBTOTAL",$J,"DILIST","ID",X,"MODIFIER",SUBM)) Q:SUBM="" D
.S MODSTR=MODSTR_$S(MODSTR]"":",",1:"")_$P(^TMP("PXBTOTAL",$J,"DILIST","ID",X,"MODIFIER",SUBM),U)
EXITNEW ;--EXIT
K DIR,^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J)
K TANA,TOTAL
Q VAL_U_$G(MODSTR)
;
;-----------------SUBROUTINES--------------
BACK ;
S START=$G(^TMP("PXBTANA",$J,"DILIST",1,1))
S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,1))
Q
FORWARD ;
S START=$G(^TMP("PXBTANA",$J,"DILIST",1,10))
S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,10))
Q
LOC ;--LOCATE CURSOR
D LOC^PXBCC(3,1) ;--LOCATE THE CURSOR
W IOEDEOP ;--CLEAR THE PAGE
Q
HEAD ;--HEAD
W !,IOCUU,IOBON,"HELP SCREEN",IOSGR0
W ?(IOM-$L(TITLE))\2,IOINHI,TITLE,IOINLOW,IOELEOL
Q
SUB ;--DISPLAY LIST TO THE SCREEN
I $P(^TMP("PXBTANA",$J,"DILIST",0),"^",1)=0 W !!," E N D O F L I S T" Q
X HEADING
S SUB=0,CNT=0
F S SUB=$O(^TMP("PXBTANA",$J,"DILIST","ID",SUB)) Q:SUB'>0 S CNT=CNT+1 D
.S NAME=$G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,.01))
.W !,SUB,?6,NAME
Q
SETUP ;-SETP VARIABLES
S FILE=200,FIELD=.01
S HEADING="W !,""ITEM"",?6,""NAME"""
Q
PRMPT2 ;-----Yes and No prompt if only one choice
D WIN17^PXBCC(PXBCNT)
D LOC^PXBCC(15,1)
S DIR("A")="Is this the correct entry "
S DIR("B")="YES"
S DIR(0)="Y"
D ^DIR
I Y=0 S X="^"
I Y=1 S X=1
G VAL
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBGCPT4 4698 printed Dec 13, 2024@02:26:33 Page 2
PXBGCPT4 ;ISL/JVS,ESW - DOUBLE ?? GATHERING OF FORM PROCEDURES ; 5/7/03 3:35pm
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,43,108,121**;Aug 12, 1996
+2 ;
+3 ;
+4 ;
+5 WRITE !,"THIS IS NOT AN ENTRY POINT"
QUIT
+6 ;
+7 ;
DOUBLE1(FROM) ;--Entry point
+1 ;
NEW ;
+1 ;
+2 NEW FILE,FIELD,TITLE,HEADING,SUB,NAME,START,SCREEN,OK,INDEX,CYCLE
+3 NEW TOTAL,PRV,CNT,PXBPMT,CODE,SUB2,SUBM,MODSTR,CNUM,MNUM,CONT,QT,PXMDIEN
+4 ;---SETUP VARIABLES
+5 SET BACK=""
SET INDEX=""
+6 SET START=DATA
SET (CONT,SUB,SUB2,SUBM)=0
+7 ;
START1 ;--RECYCLE POINT
+1 SET TITLE="- - F O R M P R O C E D U R E S - -"
+2 ;
+3 DO GETLST^IBDF18A(CLINIC,$PIECE($TEXT(CPT^PXBAICS),";;",2),"PXBPMT",,,1,IDATE)
+4 ;
+5 SET TOTAL=PXBPMT(0)
+6 IF PXBPMT(0)>0
Begin DoDot:1
+7 SET (SUB,CNT)=""
+8 FOR
SET SUB=$ORDER(PXBPMT(SUB))
if SUB=""
QUIT
Begin DoDot:2
+9 SET CODE=$PIECE(PXBPMT(SUB),U)
+10 ;PX*1.0*108
IF '(CODE?5N!(CODE?1A4N)!(CODE?4N1A))
QUIT
+11 ;I $P($G(^ICPT($O(^ICPT("B",CODE,0)),0)),U,4) Q
+12 IF '$PIECE($$CPT^ICPTCOD(CODE,IDATE),U,7)
QUIT
+13 SET NAME=$PIECE(PXBPMT(SUB),U,2)
+14 SET CNT=CNT+1
+15 SET ^TMP("PXBTOTAL",$JOB,"DILIST","ID",CNT,.01)=CODE
+16 SET ^TMP("PXBTOTAL",$JOB,"DILIST","ID",CNT,2)=NAME
+17 SET SUBM=0
+18 FOR
SET SUBM=$ORDER(PXBPMT(SUB,"MODIFIER",SUBM))
if SUBM=""
QUIT
Begin DoDot:3
+19 SET PXMDIEN=+$$MODP^ICPTMOD(CODE,PXBPMT(SUB,"MODIFIER",SUBM),"E",IDATE)
+20 SET MODSTR=$$MOD^ICPTMOD(PXMDIEN,"I",IDATE)
+21 IF +MODSTR>0
IF $PIECE(MODSTR,U,7)
Begin DoDot:4
+22 SET ^TMP("PXBTOTAL",$JOB,"DILIST","ID",CNT,"MODIFIER",SUBM)=$PIECE(MODSTR,U,2)_U_$PIECE(MODSTR,U,3)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+23 IF $DATA(CNT)
SET TOTAL=CNT
+24 ;
+25 ;--DISPLAY IF NO MATCH FOUND
+26 IF TOTAL=0
WRITE IOCUU,IOCUU,!,IOELEOL
Begin DoDot:1
+27 ;D LOC,HEAD
+28 DO LOC
WRITE !
+29 SET RESULTS="NO PROCEDURE BLOCKS EXIST FOR AN ENCOUNTER FORM"
+30 WRITE !!!,?(IOM-$LENGTH(RESULTS))\2,RESULTS
+31 DO HELP1^PXBUTL1("CON")
+32 READ OK:DTIME
End DoDot:1
+33 IF TOTAL=0
SET TOTAL="^C"
QUIT TOTAL
+34 ;
+35 ;
+36 ;----DISPLAY LIST TO THE SCREEN
+37 SET HEADING="W !,""ITEM"",?6,""CODE"",?13,""DESCRIPTION "",IOINHI,TOTAL,"" ENTRIES"",IOINLOW"
+38 ;
LIST ;-DISPLAY LIST TO THE SCREEN
+1 ;D LOC,HEAD
+2 DO LOC
WRITE !
+3 XECUTE HEADING
+4 SET SUB=$PIECE(CONT,U)-1
+5 SET (QT,CNUM,MNUM)=0
+6 FOR
SET SUB=$ORDER(^TMP("PXBTOTAL",$JOB,"DILIST","ID",SUB))
if SUB'>0
QUIT
SET SUB2=SUB2+1
Begin DoDot:1
+7 SET CNUM=CNUM+1
+8 IF CNUM+MNUM=11
SET CONT=SUB_U_0
SET QT=1
QUIT
+9 SET CODE=$GET(^TMP("PXBTOTAL",$JOB,"DILIST","ID",SUB,.01))
+10 SET NAME=$GET(^TMP("PXBTOTAL",$JOB,"DILIST","ID",SUB,2))
+11 WRITE !,SUB,?6,CODE,?13,NAME
+12 SET SUBM=$PIECE(CONT,U,2)-1
+13 if $PIECE(CONT,U,2)>0
SET $PIECE(CONT,U,2)=0
+14 FOR
SET SUBM=$ORDER(^TMP("PXBTOTAL",$JOB,"DILIST","ID",SUB,"MODIFIER",SUBM))
if SUBM=""
QUIT
Begin DoDot:2
+15 SET MNUM=MNUM+1
+16 IF MNUM+CNUM=11
SET CONT=SUB_U_SUBM
SET QT=1
QUIT
+17 SET MODSTR=^TMP("PXBTOTAL",$JOB,"DILIST","ID",SUB,"MODIFIER",SUBM)
+18 WRITE !?6,"CPT Modifier:",?21,$PIECE(MODSTR,U),?25,$PIECE(MODSTR,U,2)
End DoDot:2
if QT
QUIT
End DoDot:1
if QT
QUIT
+19 ;
+20 ;----If There is only one selection go to proper prompting
+21 IF TOTAL=1
GOTO PRMPT2
+22 ;
PRMPT ;---WRITE PROMPT HERE
+1 DO WIN17^PXBCC(PXBCNT)
+2 DO LOC^PXBCC(15,1)
+3 WRITE !
+4 IF SUB>0
WRITE !,"Enter '^' to quit"
+5 IF '$TEST
IF TOTAL>10
WRITE !," END OF LIST"
+6 IF SUB>0
SET DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "
+7 IF '$TEST
SET DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to exit: "
+8 SET DIR("?")="Enter ITEM 'No' to select , '^' to quit"
+9 SET DIR(0)="N,A,O^0:"_SUB2_":0^I X'?.1""^"".N K X"
+10 DO ^DIR
+11 IF X=""
IF SUB>0
GOTO LIST
+12 IF X=""
IF SUB'>0
SET X="^"
+13 IF $GET(DIRUT)
KILL DIRUT
SET VAL="^C"
GOTO EXITNEW
VAL ;-----Set the VAL equal to the value
+1 SET VAL=$GET(^TMP("PXBTOTAL",$JOB,"DILIST","ID",X,2))_"^"_$GET(^TMP("PXBTOTAL",$JOB,"DILIST","ID",X,.01))
+2 SET (MODSTR,SUBM)=""
+3 FOR
SET SUBM=$ORDER(^TMP("PXBTOTAL",$JOB,"DILIST","ID",X,"MODIFIER",SUBM))
if SUBM=""
QUIT
Begin DoDot:1
+4 SET MODSTR=MODSTR_$SELECT(MODSTR]"":",",1:"")_$PIECE(^TMP("PXBTOTAL",$JOB,"DILIST","ID",X,"MODIFIER",SUBM),U)
End DoDot:1
EXITNEW ;--EXIT
+1 KILL DIR,^TMP("PXBTANA",$JOB),^TMP("PXBTOTAL",$JOB)
+2 KILL TANA,TOTAL
+3 QUIT VAL_U_$GET(MODSTR)
+4 ;
+5 ;-----------------SUBROUTINES--------------
BACK ;
+1 SET START=$GET(^TMP("PXBTANA",$JOB,"DILIST",1,1))
+2 SET START("IEN")=$GET(^TMP("PXBTANA",$JOB,"DILIST",2,1))
+3 QUIT
FORWARD ;
+1 SET START=$GET(^TMP("PXBTANA",$JOB,"DILIST",1,10))
+2 SET START("IEN")=$GET(^TMP("PXBTANA",$JOB,"DILIST",2,10))
+3 QUIT
LOC ;--LOCATE CURSOR
+1 ;--LOCATE THE CURSOR
DO LOC^PXBCC(3,1)
+2 ;--CLEAR THE PAGE
WRITE IOEDEOP
+3 QUIT
HEAD ;--HEAD
+1 WRITE !,IOCUU,IOBON,"HELP SCREEN",IOSGR0
+2 WRITE ?(IOM-$LENGTH(TITLE))\2,IOINHI,TITLE,IOINLOW,IOELEOL
+3 QUIT
SUB ;--DISPLAY LIST TO THE SCREEN
+1 IF $PIECE(^TMP("PXBTANA",$JOB,"DILIST",0),"^",1)=0
WRITE !!," E N D O F L I S T"
QUIT
+2 XECUTE HEADING
+3 SET SUB=0
SET CNT=0
+4 FOR
SET SUB=$ORDER(^TMP("PXBTANA",$JOB,"DILIST","ID",SUB))
if SUB'>0
QUIT
SET CNT=CNT+1
Begin DoDot:1
+5 SET NAME=$GET(^TMP("PXBTANA",$JOB,"DILIST","ID",SUB,.01))
+6 WRITE !,SUB,?6,NAME
End DoDot:1
+7 QUIT
SETUP ;-SETP VARIABLES
+1 SET FILE=200
SET FIELD=.01
+2 SET HEADING="W !,""ITEM"",?6,""NAME"""
+3 QUIT
PRMPT2 ;-----Yes and No prompt if only one choice
+1 DO WIN17^PXBCC(PXBCNT)
+2 DO LOC^PXBCC(15,1)
+3 SET DIR("A")="Is this the correct entry "
+4 SET DIR("B")="YES"
+5 SET DIR(0)="Y"
+6 DO ^DIR
+7 IF Y=0
SET X="^"
+8 IF Y=1
SET X=1
+9 GOTO VAL
+10 ;
