- PXBGPRV4 ;ISL/JVS - DOUBLE ?? GATHERING OF FORM PROVIDERS ;10/15/96 11:56
- ;;1.0;PCE PATIENT CARE ENCOUNTER;**7,11**;Aug 12, 1996
- ;
- ;
- ;
- W !,"THIS IS NOT AN ENTRY POINT" Q
- ;
- ;
- DOUBLE1(FROM) ;--Entry point
- ;
- NEW ;
- ;
- N FILE,FIELD,TITLE,HEADING,SUB,CODE,NAME,START,SCREEN,CNT,OK,INDEX,CYCLE
- N TOTAL,PRV,CNT,PXBPMT,CODE,SUB2
- ;---SETUP VARIABLES
- S BACK="",INDEX=""
- S START=DATA,SUB=0,SUB2=0
- ;
- START1 ;--RECYCLE POINT
- S TITLE="- - F O R M P R O V I D E R S - -"
- ;
- D GETLST^IBDF18A(CLINIC,$P($T(PRV^PXBAICS),";;",2),"PXBPMT")
- TEST ;
- S TOTAL=PXBPMT(0)
- I PXBPMT(0)>0 D
- .S SUB=1,CNT="" F S SUB=$O(PXBPMT(SUB)) Q:SUB="" D
- ..S NAME=$P($G(PXBPMT(SUB)),"^",2)
- ..S CNT=CNT+1
- ..S ^TMP("PXBTOTAL",$J,"DILIST","ID",CNT,.01)=NAME
- ..S ^TMP("PXBTOTAL",$J,"DILIST",2,CNT)=$P($G(PXBPMT(SUB)),"^",1)
- I $D(CNT) S TOTAL=CNT
- ;
- ;--DISPLAY IF NO MATCH FOUND
- I TOTAL=0 W IOCUU,IOCUU,!,IOELEOL D
- .D LOC W !
- .S RESULTS="NO PROVIDER BLOCKS EXIST FOR AN ENCOUNTER FORM" W !!!,?(IOM-$L(RESULTS))\2,RESULTS D HELP1^PXBUTL1("CON") R OK:DTIME
- I TOTAL=0 Q TOTAL
- ;
- ;
- ;----DISPLAY LIST TO THE SCREEN
- S HEADING="W !,""ITEM"",?6,""NAME"",IOINHI,TOTAL,"" ENTRIES"",IOINLOW,?30,"" PERSON CLASS IN NEW PERSON FILE"""
- LIST ;-DISPLAY LIST TO THE SCREEN
- D LOC W !
- X HEADING
- S SUB=SUB-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
- .S NAME=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,.01))
- .S TYPE=$$OCCUP^PXBGPRV($G(^TMP("PXBTOTAL",$J,"DILIST",2,SUB)),+$P($G(^AUPNVSIT(PXBVST,0)),"^",1),"",2) D
- ..N Y,DATE
- ..S Y=+$P($G(^AUPNVSIT(PXBVST,0)),"^",1) X ^DD("DD") S DATE=$P(Y,"@",1)
- ..I +TYPE=-2 S TYPE="*** CLASS not 'ACTIVE' on "_DATE_"***"
- ..I +TYPE=-1 S TYPE=""
- .W !,SUB,?6,$E(NAME,1,20),?30,$E(TYPE,1,45)
- ;
- ;----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="^P" G EXITNEW
- VAL ;-----Set the VAL equal to the value
- S VAL=$G(^TMP("PXBTOTAL",$J,"DILIST",2,X))_"^"_$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,.01))
- EXITNEW ;--EXIT
- K DIR,^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J)
- K TANA,TOTAL
- Q VAL
- Q
- ;
- ;-----------------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,?(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 D
- S HEADING="W !,""ITEM"",?6,""NAME"""
- Q
- PRMPT2 ;-----Yes and No prompt if onlyi 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
- PXBGPRV4 ;ISL/JVS - DOUBLE ?? GATHERING OF FORM PROVIDERS ;10/15/96 11:56
- +1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**7,11**;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,CODE,NAME,START,SCREEN,CNT,OK,INDEX,CYCLE
- +3 NEW TOTAL,PRV,CNT,PXBPMT,CODE,SUB2
- +4 ;---SETUP VARIABLES
- +5 SET BACK=""
- SET INDEX=""
- +6 SET START=DATA
- SET SUB=0
- SET SUB2=0
- +7 ;
- START1 ;--RECYCLE POINT
- +1 SET TITLE="- - F O R M P R O V I D E R S - -"
- +2 ;
- +3 DO GETLST^IBDF18A(CLINIC,$PIECE($TEXT(PRV^PXBAICS),";;",2),"PXBPMT")
- TEST ;
- +1 SET TOTAL=PXBPMT(0)
- +2 IF PXBPMT(0)>0
- Begin DoDot:1
- +3 SET SUB=1
- SET CNT=""
- FOR
- SET SUB=$ORDER(PXBPMT(SUB))
- IF SUB=""
- QUIT
- Begin DoDot:2
- +4 SET NAME=$PIECE($GET(PXBPMT(SUB)),"^",2)
- +5 SET CNT=CNT+1
- +6 SET ^TMP("PXBTOTAL",$JOB,"DILIST","ID",CNT,.01)=NAME
- +7 SET ^TMP("PXBTOTAL",$JOB,"DILIST",2,CNT)=$PIECE($GET(PXBPMT(SUB)),"^",1)
- End DoDot:2
- End DoDot:1
- +8 IF $DATA(CNT)
- SET TOTAL=CNT
- +9 ;
- +10 ;--DISPLAY IF NO MATCH FOUND
- +11 IF TOTAL=0
- WRITE IOCUU,IOCUU,!,IOELEOL
- Begin DoDot:1
- +12 DO LOC
- WRITE !
- +13 SET RESULTS="NO PROVIDER BLOCKS EXIST FOR AN ENCOUNTER FORM"
- WRITE !!!,?(IOM-$LENGTH(RESULTS))\2,RESULTS
- DO HELP1^PXBUTL1("CON")
- READ OK:DTIME
- End DoDot:1
- +14 IF TOTAL=0
- QUIT TOTAL
- +15 ;
- +16 ;
- +17 ;----DISPLAY LIST TO THE SCREEN
- +18 SET HEADING="W !,""ITEM"",?6,""NAME"",IOINHI,TOTAL,"" ENTRIES"",IOINLOW,?30,"" PERSON CLASS IN NEW PERSON FILE"""
- LIST ;-DISPLAY LIST TO THE SCREEN
- +1 DO LOC
- WRITE !
- +2 XECUTE HEADING
- +3 SET SUB=SUB-1
- +4 SET NUM=0
- FOR
- SET SUB=$ORDER(^TMP("PXBTOTAL",$JOB,"DILIST","ID",SUB))
- SET NUM=NUM+1
- IF NUM=11
- QUIT
- IF SUB'>0
- QUIT
- SET SUB2=SUB2+1
- Begin DoDot:1
- +5 SET NAME=$GET(^TMP("PXBTOTAL",$JOB,"DILIST","ID",SUB,.01))
- +6 SET TYPE=$$OCCUP^PXBGPRV($GET(^TMP("PXBTOTAL",$JOB,"DILIST",2,SUB)),+$PIECE($GET(^AUPNVSIT(PXBVST,0)),"^",1),"",2)
- Begin DoDot:2
- +7 NEW Y,DATE
- +8 SET Y=+$PIECE($GET(^AUPNVSIT(PXBVST,0)),"^",1)
- XECUTE ^DD("DD")
- SET DATE=$PIECE(Y,"@",1)
- +9 IF +TYPE=-2
- SET TYPE="*** CLASS not 'ACTIVE' on "_DATE_"***"
- +10 IF +TYPE=-1
- SET TYPE=""
- End DoDot:2
- +11 WRITE !,SUB,?6,$EXTRACT(NAME,1,20),?30,$EXTRACT(TYPE,1,45)
- End DoDot:1
- +12 ;
- +13 ;----If There is only one selection go to proper prompting
- +14 IF TOTAL=1
- GOTO PRMPT2
- +15 ;
- 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="^P"
- GOTO EXITNEW
- VAL ;-----Set the VAL equal to the value
- +1 SET VAL=$GET(^TMP("PXBTOTAL",$JOB,"DILIST",2,X))_"^"_$GET(^TMP("PXBTOTAL",$JOB,"DILIST","ID",X,.01))
- EXITNEW ;--EXIT
- +1 KILL DIR,^TMP("PXBTANA",$JOB),^TMP("PXBTOTAL",$JOB)
- +2 KILL TANA,TOTAL
- +3 QUIT VAL
- +4 QUIT
- +5 ;
- +6 ;-----------------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,?(IOM-$LENGTH(TITLE))\2,IOINHI,TITLE,IOINLOW,IOELEOL
- +2 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
- FOR
- SET SUB=$ORDER(^TMP("PXBTANA",$JOB,"DILIST","ID",SUB))
- IF SUB'>0
- QUIT
- SET CNT=CNT+1
- Begin DoDot:1
- +4 SET NAME=$GET(^TMP("PXBTANA",$JOB,"DILIST","ID",SUB,.01))
- +5 WRITE !,SUB,?6,NAME
- End DoDot:1
- +6 QUIT
- SETUP ;-SETP VARIABLES
- +1 SET FILE=200
- SET FIELD=.01
- Begin DoDot:1
- End DoDot:1
- +2 SET HEADING="W !,""ITEM"",?6,""NAME"""
- +3 QUIT
- PRMPT2 ;-----Yes and No prompt if onlyi 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