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

PXBGCPT2.m

Go to the documentation of this file. 
  1. PXBGCPT2 ;ISL/JVS,ESW - DOUBLE ?? GATHERING OF CPT CODES ; 10/31/02 12:05pm
  1.  ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,19,108**;Aug 12, 1996
  1.  ;
  1.  ;
  1.  ;
  1.  W !,"NOT" Q
  1.  ;
  1. DOUBLE(FROM) ;--Entry
  1.  ;
  1.  N FILE,FIELD,TITLE,HEADING,SUB,CODE,NAME,START,SCREEN,BACK,NUM
  1.  N SCREEN,TEMP,FIRST
  1.  S BACK="",NUM=0,SCREEN=""
  1.  D LOC
  1.  I $D(DIC("S")) S SCREEN=DIC("S")
  1.  ;
  1. START ;
  1.  ;
  1.  S TITLE="- - A L L  P R O C E D U R E (CPT CODES) - -"
  1.  ;
  1.  D SETUP
  1.  D LIST^DIC(FILE,"",FIELD,BACK,10,.START,"","",SCREEN,"","^TMP(""PXBTANA"",$J)","^TMP(""PXBTANA"",$J)")
  1.  ;
  1.  D LOC,HEAD,SUB
  1.  ;
  1. PROMPT ;--PROMPT
  1.  D WIN17^PXBCC(PXBCNT),LOC^PXBCC(15,1)
  1.  W !!,"Enter '^' to quit,  '-' for previous page."
  1.  S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "
  1.  S DIR("?")="Enter ITEM 'No' to select , '^' to quit,  '-' for previous page."
  1.  S DIR(0)="N,A,O^0:10:0^I X'?.1""-"".1""^"".2N!(+X>10) K X"
  1.  D ^DIR
  1.  I X="-" S BACK="B" D BACK G START
  1.  I X="" S BACK="" D FORWARD G START
  1.  I $G(DIRUT) K DIRUT S VAL="^C" G EXIT
  1. FINISH ;--FINISH
  1.  ;
  1.  S VAL=$G(^TMP("PXBTANA",$J,"DILIST",2,X))_U_$G(^TMP("PXBTANA",$J,"DILIST","ID",X,FIRST))_"--"_$G(^TMP("PXBTANA",$J,"DILIST","ID",X,SECOND))
  1. EXIT ;--EXIT
  1.  K DIR,^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J)
  1.  Q VAL
  1.  ;
  1. DOUBLE1(FROM) ;--Entry
  1.  ;
  1. NEW ;
  1.  N FILE,FIELD,TITLE,HEADING,SUB,CODE,NAME,START,SCREEN,CNT,OK,INDEX,CYCLE
  1.  N TOTAL,FIRST,SUB2
  1.  ;---SETUP
  1.  S BACK="",INDEX=""
  1.  S START=DATA,SUB=0,SUB2=0
  1.  ;
  1. START1 ;--RECYCLE
  1.  S TITLE="- - S E L E C T E D  P R O C E D U R E S (CPT CODES) - -"
  1.  S FILE=81
  1.  S FIELD=".01;2"
  1.  N TMP,LL,TT
  1.  S LL=$L(DATA),TT="0000"
  1.  I DATA?1.4N!(DATA?1A.3N) D
  1.  .S START=$O(^ICPT("B",DATA_$E(TT,1,5-LL)),-1)
  1.  I DATA?5N!(DATA?1A4N)!(DATA?4N1A) D
  1.  .S START=$O(^ICPT("B",START),-1)
  1. XXX W IOCUOFF,IOCUF,IOCUF
  1.  N TMP
  1.  S SUBT=START,TOTAL=0 F  S SUBT=$O(^ICPT("B",SUBT)) Q:SUBT'[DATA  D
  1.  .I '$$CPTSCREN^PXBUTL($O(^ICPT("B",SUBT,0)),IDATE) Q
  1.  .S TOTAL=TOTAL+1 S PXBMOD=TOTAL#100 D WAIT^PXBUTL
  1.  .S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,.01)=SUBT
  1.  .S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,2)=$P(^ICPT($O(^ICPT("B",SUBT,0)),0),U,2)
  1.  .S TMP(SUBT)=""
  1.  I DATA?1.4N!(DATA?.3N1A) D
  1.  .S START=$O(^ICPT("B",$E(TT,1,5-LL)_DATA),-1)
  1.  .S SUBT=START F  S SUBT=$O(^ICPT("B",SUBT)) Q:SUBT'[DATA  D
  1.  ..Q:$D(TMP(SUBT))
  1.  ..I '$$CPTSCREN^PXBUTL($O(^ICPT("B",SUBT,0)),IDATE) Q
  1.  ..S TOTAL=TOTAL+1 S PXBMOD=TOTAL#100 D WAIT^PXBUTL
  1.  ..S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,.01)=SUBT
  1.  ..S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,2)=$P(^ICPT($O(^ICPT("B",SUBT,0)),0),U,2)
  1.  W IOCUON
  1.  ;
  1.  ;
  1.  ;
  1.  I DATA?2.A W IOCUOFF,IOCUF,IOCUF S SUBT=$O(^ICPT("C",DATA),-1) F  S SUBT=$O(^ICPT("C",SUBT)) Q:SUBT'[DATA  D
  1.  .N IEN,CODE
  1.  .S IEN="" F  S IEN=$O(^ICPT("C",SUBT,IEN)) Q:IEN=""  D
  1.  ..S CODE=$P(^ICPT(IEN,0),U) I '$$CPTSCREN^PXBUTL(CODE,IDATE) Q
  1.  ..S TOTAL=TOTAL+1 S PXBMOD=TOTAL#100 D WAIT^PXBUTL
  1.  ..S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,.01)=$P(^ICPT(IEN,0),U)
  1.  ..S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,2)=SUBT_", "_$P(^ICPT(IEN,0),U,2)
  1.  W IOCUON
  1.  K SUBT
  1.  ;
  1.  ;
  1.  ;
  1.  ;--NO MATCH
  1.  I TOTAL=0 D
  1.  .I DATA?1A W ! D HELP^PXBUTL0("CPT4")
  1.  .I DATA'?1A W ! D HELP^PXBUTL0("CPTM")
  1.  .S ERROR=1,CYCL=1
  1.  I TOTAL=0 Q TOTAL
  1.  ;
  1.  ;--LIST
  1.  S HEADING="W !,""ITEM"",?6,""CODE"",?15,""DESCRIPTION   "",IOINHI,TOTAL,"" MATCHES"",IOINLOW"
  1. LIST ;-DISPLAY LIST TO THE SCREEN
  1.  I TOTAL=1 S X=1 G VAL
  1.  D LOC W !
  1.  X HEADING
  1.  S SUB=SUB-1
  1.  S NUM=0 F  S SUB=$O(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB)) S NUM=NUM+1 Q:NUM=11  Q:SUB'>0  S SUB2=SUB2+1 D
  1.  .S CODE=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,.01))
  1.  .S NAME=$E($G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,2)),1,64)
  1.  .W !,SUB,?6,CODE,?15,NAME
  1.  ;
  1.  ;--one
  1.  I TOTAL=1 G PRMPT2
  1.  ;
  1. PRMPT ;--PROMPT
  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. VAL ;--VAL equal value
  1.  S VAL=$G(^TMP("PXBTOTAL",$J,"DILIST",2,X))_U_$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,.01))_"--"_$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,2))
  1. EXITNEW ;--EXIT
  1.  K DIR,DIRUT,^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J)
  1.  K TANA,TOTAL
  1.  Q VAL
  1.  Q
  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,?(IOM-$L(TITLE))\2,IOINHI,TITLE,IOINLOW,IOELEOL
  1.  Q
  1. SUB ;--LIST
  1.  I $P(^TMP("PXBTANA",$J,"DILIST",0),U)=0 W !!,"     E N D  O F  L I S T" Q
  1.  X HEADING
  1.  S SUB=0,CNT=0 F  S SUB=$O(^TMP("PXBTANA",$J,"DILIST","ID",SUB)) Q:SUB'>0  S CNT=CNT+1 D
  1.  .S CODE=$G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,FIRST))
  1.  .S NAME=$G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,SECOND))
  1.  .W !,SUB,?6,CODE,?15,NAME
  1.  Q
  1. SETUP ;--SET
  1.  S FILE=81,FIRST=.01,SECOND=2
  1.  S FIELD=FIRST_";"_SECOND
  1.  S HEADING="W !,""ITEM"",?6,""CODE"",?15,""DESCRIPTION"""
  1.  Q
  1. PRMPT2 ;--Yes and No prompt
  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.  ;