Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXBGCPT4

PXBGCPT4.m

Go to the documentation of this file. 
  1. PXBGCPT4 ;ISL/JVS,ESW - DOUBLE ?? GATHERING OF FORM PROCEDURES ; 10/31/02 12:06pm
  1.  ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,43,108**;Aug 12, 1996
  1.  ;
  1.  ;
  1.  ;
  1.  W !,"THIS IS NOT AN ENTRY POINT" Q
  1.  ;  
  1.  ;
  1. DOUBLE1(FROM) ;--Entry point
  1.  ;
  1. NEW ;
  1.  ;
  1.  N FILE,FIELD,TITLE,HEADING,SUB,NAME,START,SCREEN,OK,INDEX,CYCLE
  1.  N TOTAL,PRV,CNT,PXBPMT,CODE,SUB2,SUBM,MODSTR,CNUM,MNUM,CONT,QT,PXMDIEN
  1.  ;---SETUP VARIABLES
  1.  S BACK="",INDEX=""
  1.  S START=DATA,(CONT,SUB,SUB2,SUBM)=0
  1.  ;
  1. START1 ;--RECYCLE POINT
  1.  S TITLE="- - F O R M    P R O C E D U R E S - -"
  1.  ;
  1.  D GETLST^IBDF18A(CLINIC,$P($T(CPT^PXBAICS),";;",2),"PXBPMT",,,1)
  1.  ;
  1.  S TOTAL=PXBPMT(0)
  1.  I PXBPMT(0)>0 D
  1.  .S (SUB,CNT)=""
  1.  .F  S SUB=$O(PXBPMT(SUB)) Q:SUB=""  D
  1.  ..S CODE=$P(PXBPMT(SUB),U)
  1.  ..I '(CODE?5N!(CODE?1A4N)!(CODE?4N1A)) Q  ;PX*1.0*108
  1.  ..I $P($G(^ICPT($O(^ICPT("B",CODE,0)),0)),U,4) Q
  1.  ..S NAME=$P(PXBPMT(SUB),U,2)
  1.  ..S CNT=CNT+1
  1.  ..S ^TMP("PXBTOTAL",$J,"DILIST","ID",CNT,.01)=CODE
  1.  ..S ^TMP("PXBTOTAL",$J,"DILIST","ID",CNT,2)=NAME
  1.  ..S SUBM=0
  1.  ..F  S SUBM=$O(PXBPMT(SUB,"MODIFIER",SUBM)) Q:SUBM=""  D
  1.  ...S PXMDIEN=+$$MODP^ICPTMOD(CODE,PXBPMT(SUB,"MODIFIER",SUBM),"E")
  1.  ...S MODSTR=$$MOD^ICPTMOD(PXMDIEN,"I")
  1.  ...I +MODSTR>0,$P(MODSTR,U,7) D
  1.  ....S ^TMP("PXBTOTAL",$J,"DILIST","ID",CNT,"MODIFIER",SUBM)=$P(MODSTR,U,2)_U_$P(MODSTR,U,3)
  1.  I $D(CNT) S TOTAL=CNT
  1.  ;
  1.  ;--DISPLAY IF NO MATCH FOUND
  1.  I TOTAL=0 W IOCUU,IOCUU,!,IOELEOL D
  1.  .;D LOC,HEAD
  1.  .D LOC W !
  1.  .S RESULTS="NO PROCEDURE BLOCKS EXIST FOR AN ENCOUNTER FORM"
  1.  .W !!!,?(IOM-$L(RESULTS))\2,RESULTS
  1.  .D HELP1^PXBUTL1("CON")
  1.  .R OK:DTIME
  1.  I TOTAL=0 S TOTAL="^C" Q TOTAL
  1.  ;
  1.  ;
  1.  ;----DISPLAY LIST TO THE SCREEN
  1.  S HEADING="W !,""ITEM"",?6,""CODE"",?13,""DESCRIPTION   "",IOINHI,TOTAL,"" ENTRIES"",IOINLOW"
  1.  ;
  1. LIST ;-DISPLAY LIST TO THE SCREEN
  1.  ;D LOC,HEAD
  1.  D LOC W !
  1.  X HEADING
  1.  S SUB=$P(CONT,U)-1
  1.  S (QT,CNUM,MNUM)=0
  1.  F  S SUB=$O(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB)) Q:SUB'>0  S SUB2=SUB2+1 D  Q:QT
  1.  .S CNUM=CNUM+1
  1.  .I CNUM+MNUM=11 S CONT=SUB_U_0,QT=1 Q
  1.  .S CODE=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,.01))
  1.  .S NAME=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,2))
  1.  .W !,SUB,?6,CODE,?13,NAME
  1.  .S SUBM=$P(CONT,U,2)-1
  1.  .S:$P(CONT,U,2)>0 $P(CONT,U,2)=0
  1.  .F  S SUBM=$O(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,"MODIFIER",SUBM)) Q:SUBM=""  D  Q:QT
  1.  ..S MNUM=MNUM+1
  1.  ..I MNUM+CNUM=11 S CONT=SUB_U_SUBM,QT=1 Q
  1.  ..S MODSTR=^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,"MODIFIER",SUBM)
  1.  ..W !?6,"CPT Modifier:",?21,$P(MODSTR,U),?25,$P(MODSTR,U,2)
  1.  ;
  1.  ;----If There is only one selection go to proper prompting
  1.  I TOTAL=1 G PRMPT2
  1.  ;
  1. PRMPT ;---WRITE PROMPT HERE
  1.  D WIN17^PXBCC(PXBCNT)
  1.  D LOC^PXBCC(15,1)
  1.  W !
  1.  I SUB>0 W !,"Enter '^' to quit"
  1.  E  I TOTAL>10 W !,"               END OF LIST"
  1.  I SUB>0 S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "
  1.  E  S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to exit: "
  1.  S DIR("?")="Enter ITEM 'No' to select , '^' to quit"
  1.  S DIR(0)="N,A,O^0:"_SUB2_":0^I X'?.1""^"".N K X"
  1.  D ^DIR
  1.  I X="",SUB>0 G LIST
  1.  I X="",SUB'>0 S X="^"
  1.  I $G(DIRUT) K DIRUT S VAL="^C" G EXITNEW
  1. VAL ;-----Set the VAL equal to the value
  1.  S VAL=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,2))_"^"_$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,.01))
  1.  S (MODSTR,SUBM)=""
  1.  F  S SUBM=$O(^TMP("PXBTOTAL",$J,"DILIST","ID",X,"MODIFIER",SUBM)) Q:SUBM=""  D
  1.  .S MODSTR=MODSTR_$S(MODSTR]"":",",1:"")_$P(^TMP("PXBTOTAL",$J,"DILIST","ID",X,"MODIFIER",SUBM),U)
  1. EXITNEW ;--EXIT
  1.  K DIR,^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J)
  1.  K TANA,TOTAL
  1.  Q VAL_U_$G(MODSTR)
  1.  ;
  1.  ;-----------------SUBROUTINES--------------
  1. BACK ;
  1.  S START=$G(^TMP("PXBTANA",$J,"DILIST",1,1))
  1.  S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,1))
  1.  Q
  1. FORWARD ;
  1.  S START=$G(^TMP("PXBTANA",$J,"DILIST",1,10))
  1.  S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,10))
  1.  Q
  1. LOC ;--LOCATE CURSOR
  1.  D LOC^PXBCC(3,1) ;--LOCATE THE CURSOR
  1.  W IOEDEOP ;--CLEAR THE PAGE
  1.  Q
  1.  W !,IOCUU,IOBON,"HELP SCREEN",IOSGR0
  1.  W ?(IOM-$L(TITLE))\2,IOINHI,TITLE,IOINLOW,IOELEOL
  1.  Q
  1. SUB ;--DISPLAY LIST TO THE SCREEN
  1.  I $P(^TMP("PXBTANA",$J,"DILIST",0),"^",1)=0 W !!,"     E N D  O F  L I S T" Q
  1.  X HEADING
  1.  S SUB=0,CNT=0
  1.  F  S SUB=$O(^TMP("PXBTANA",$J,"DILIST","ID",SUB)) Q:SUB'>0  S CNT=CNT+1 D
  1.  .S NAME=$G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,.01))
  1.  .W !,SUB,?6,NAME
  1.  Q
  1. SETUP ;-SETP VARIABLES
  1.  S FILE=200,FIELD=.01
  1.  S HEADING="W !,""ITEM"",?6,""NAME"""
  1.  Q
  1. PRMPT2 ;-----Yes and No prompt if only one choice
  1.  D WIN17^PXBCC(PXBCNT)
  1.  D LOC^PXBCC(15,1)
  1.  S DIR("A")="Is this the correct entry "
  1.  S DIR("B")="YES"
  1.  S DIR(0)="Y"
  1.  D ^DIR
  1.  I Y=0 S X="^"
  1.  I Y=1 S X=1
  1.  G VAL
  1.  ;