- SCRPO5 ;BP-CIOFO/KEITH - Historical Patient Assignment Detail ; 01 Jul 99 9:30 PM
- ;;5.3;Scheduling;**177,505**;AUG 13, 1993;Build 20
- ;
- PTDET N DIC,SC,DFN,SCPT0,X,Y,SCDT,DTOUT,DUOUT
- D TITL^SCRPW50("Historical Patient Assignment Detail")
- S DIC="^DPT(",DIC(0)="AEMQZ" D ^DIC I $D(DTOUT)!$D(DUOUT) G EXIT
- G:Y<1 EXIT S DFN=+Y,SCPT0=Y(0),SC="SC",SCDT("B")="TODAY"
- G:'$$DTR^SCRPO(.SC,.SCDT,.SCDT) EXIT
- N ZTSAVE F X="DFN","SCPT0","SC(" S ZTSAVE(X)=""
- W ! D EN^XUTMDEVQ("RUN^SCRPO5","Historical Patient Assignment Detail",.ZTSAVE)
- EXIT D DISP0^SCRPW23,END^SCRPW50 Q
- ;
- RUN ;Print report
- N SCI,SCPNOW,SCLINE,SCPAGE,SCSUB,SCFF,SCFOUND,SCLN,SCAGE,SCDATA
- N SCDOB,SCGEND,SCIFN,SCOUT,SCPNAME,SCREC,SCSH,SCSSN,SCTITL,SCDT
- N SCEU,SCEUNM,SCLEBNM,SCLEDT,SCSTAT,SCSTNM,SCX,SCY
- K ^TMP("SCRPT",$J) M SCDT=SC("DTR") S SCDT="SCDT"
- S SCI=$$GETALL^SCAPMCA(DFN,.SCDT),SCSUB="",(SCFF,SCLN,SCFOUND,SCOUT)=0
- F S SCSUB=$O(^TMP("SC",$J,DFN,SCSUB)) Q:SCSUB=""!(SCSUB]"PCTM") D
- .S SCX=$P($T(@SCSUB),";;",2) F SCI=1:1:9 S SCX(SCI)=$P(SCX,U,SCI)
- .S ^TMP("SCRPT",$J,SCX(1))=SCX(2),SCX(3)=U_SCX(3)
- .S SCI=0 F S SCI=$O(^TMP("SC",$J,DFN,SCSUB,SCI)) Q:'SCI D
- ..S SCDATA=^TMP("SC",$J,DFN,SCSUB,SCI)
- ..S SCNAME=$P(SCDATA,U,SCX(8)) ;provider/position/team name
- ..S SCIFN=$P(SCDATA,U,SCX(4)) ;history record ifn
- ..S SCACT=$P(SCDATA,U,SCX(5)) ;active date
- ..Q:'SCACT
- ..S SCINAC=$P(SCDATA,U,SCX(6)) ;inactive date
- ..S SCREC=$G(@SCX(3)@(SCIFN,0)) ;history record
- ..Q:'$L(SCREC)
- ..S SCUSER=$P(SCREC,U,SCX(7)) ;user duz
- ..S SCDENT=$P(SCREC,U,SCX(9)) ;date entered
- ..S SCEU=$P(SCREC,U,6),SCEUNM=$$GET1^DIQ(200,SCEU_",",.01) ;editing user
- ..S SCSTAT=$P(SCREC,U,12),SCSTNM=$$GET1^DIQ(404.43,SCIFN_",",.12) ;status
- ..S SCLEDT=$P(SCREC,U,8),SCLEBNM=$$GET1^DIQ(200,SCLEDT_",",.01) ;last edited by
- ..D SLINE(SCX(1),SCNAME,SCACT,SCINAC,SCUSER,SCDENT,SCEUNM,SCSTNM,SCLEBNM,.SCLN)
- ..Q
- .Q
- S SCTITL(1)="<*> HISTORICAL PATIENT ASSIGNMENT DETAIL <*>"
- S SCTITL(2)="For assignments effective "_SC("DTR","PBDT")_" to "_SC("DTR","PEDT")
- S SCLINE="",$P(SCLINE,"-",81)="",SCPAGE=1
- S Y=$$NOW^XLFDT() X ^DD("DD") S SCPNOW=$P(Y,":",1,2)
- S SCPNAME=$P(SCPT0,U),SCSSN=$P(SCPT0,U,9)
- S SCGEND=$S($P(SCPT0,U,2)="M":"MALE",1:"FEMALE")
- S (Y,SCAGE)=$P(SCPT0,U,3) X ^DD("DD") S SCDOB=Y
- S SCAGE=$E(DT,1,3)-$E(SCAGE,1,3)-($E(DT,4,7)<$E(SCAGE,4,7))
- D:$E(IOST)="C" DISP0^SCRPW23 D HDR^SCRPO(.SCTITL,80),SHDR
- W:'SCFOUND !!?21,"No assignments found for this patient."
- I SCFOUND S SCSUB=0 F S SCSUB=$O(^TMP("SCRPT",$J,SCSUB)) Q:'SCSUB!SCOUT D
- .D:$Y>(IOSL-5) HDR^SCRPO(.SCTITL,80),SHDR Q:SCOUT
- .S SCSH=^TMP("SCRPT",$J,SCSUB)
- .W:SCSUB>1 ! D SSHDR(SCSH) S SCACT=""
- .I '$O(^TMP("SCRPT",$J,SCSUB,"")) W " (none found)" Q
- .F S SCACT=$O(^TMP("SCRPT",$J,SCSUB,SCACT)) Q:SCACT=""!SCOUT D
- ..S SCI=0 F S SCI=$O(^TMP("SCRPT",$J,SCSUB,SCACT,SCI)) Q:'SCI!SCOUT D
- ...D:$Y>(IOSL-3) HDR^SCRPO(.SCTITL,80),SHDR,SSHDR(SCSH,1) Q:SCOUT
- ...S SCX=^TMP("SCRPT",$J,SCSUB,SCACT,SCI)
- ...W !,$P(SCX,U),?28,$P(SCX,U,2),?40,$P(SCX,U,3),?52,$P(SCX,U,4)
- ...I SCSUB=3 D
- ....W !,"User Entering: ",$P(SCX,U,6)
- ....W !,"Last Edited By: ",$P(SCX,U,7)
- ....W !,"Status: ",$P(SCX,U,5)
- ...Q
- ..Q
- .Q
- I 'SCOUT,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
- K ^TMP("SCRPT",$J) Q
- ;
- SHDR ;Subheader
- Q:SCOUT
- W !,"Patient: ",$E(SCPNAME,1,18),?29,"SSN: ",SCSSN,?46,"DOB: ",SCDOB
- W ?64,"AGE: ",SCAGE,?74,$J(SCGEND,6),!,SCLINE
- Q:'SCFOUND
- W !,"Assignment",?28,"Active",?40,"Inactive",?52,"Assigned by/date"
- W !,"-------------------------- ---------- ---------- ----------------------------"
- Q
- ;
- SSHDR(X,CONT) ;Subheader
- ;Input: X=category
- ;Input: CONT='1' for continuation (optional)
- W !,X,$S($G(CONT):" (cont.)",1:""),":"
- Q
- ;
- SLINE(SCORD,SCNAME,SCACT,SCINAC,SCUSER,SCDENT,SUNM,SCTNM,SCBNM,SCLN) ;Set report global
- ;Input: SCORD=output order
- ;Input: SCNAME=provider/position/team name
- ;Input: SCACT=active date
- ;Input: SCINAC=inactive date
- ;Input: SCUSER=user duz
- ;Input: SCDENT=date entered
- ;Input: SUNM=entered by
- ;Input: SCTNM=status
- ;Input: SCBNM=last edited by
- ;
- ;N SCX,SCY
- S SCFOUND=1,SCLN=SCLN+1
- S SCX=$E(SCNAME,1,25)_U_$$SDT(SCACT)_U_$$SDT(SCINAC),SCY=$$SDT(SCDENT)
- S:$L(SCY) SCY=" ("_SCY_")"
- S SCX=SCX_U_$E($P($G(^VA(200,+SCUSER,0)),U),1,(28-$L(SCY)))_SCY_U_SCTNM_U_SUNM_U_SCBNM
- S ^TMP("SCRPT",$J,SCORD,-SCACT,SCLN)=SCX
- Q
- ;
- CODE ;Data handling instructions
- ; The following $TEXT lines contain data handling instructions
- ; in the format: $PIECE 1 = output order
- ; 2 = subtitle
- ; 3 = global reference of history record
- ; 4 = $piece of history record ifn
- ; 5 = $piece of active date
- ; 6 = $piece of inactive date
- ; 7 = $piece of user (in history record)
- ; 8 = $piece of provider/position/team name
- ; 9 = $piece of date entered
- ;
- NPCPOS ;;7^Non-PC Position^SCPT(404.43)^4^5^6^6^2^7
- NPCPPOS ;;9^Non-PC Preceptor Position^SCTM(404.53)^16^14^15^7^2^8
- NPCPPR ;;8^Non-PC Preceptor Provider^SCTM(404.52)^11^9^10^7^2^8
- NPCPR ;;6^Non-PC Provider^SCTM(404.52)^11^9^10^7^2^8
- NPCTM ;;10^Non-PC Team^SCPT(404.42)^3^4^5^11^2^12
- PCAP ;;2^PC Associate Provider^SCTM(404.52)^11^9^10^7^2^8
- PCPOS ;;3^PC Position^SCPT(404.43)^4^5^6^6^2^7
- PCPPOS ;;4^PC Preceptor Position^SCTM(404.53)^16^14^15^7^2^8
- PCPR ;;1^PC Provider^SCTM(404.52)^11^9^10^7^2^8
- PCTM ;;5^PC Team^SCPT(404.42)^3^4^5^11^2^12
- ;
- SDT(X) ;Slashed date
- S X=$E(X,1,7) Q:X'?7N ""
- Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_(17+$E(X))_$E(X,2,3)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPO5 5688 printed Mar 13, 2025@21:47:39 Page 2
- SCRPO5 ;BP-CIOFO/KEITH - Historical Patient Assignment Detail ; 01 Jul 99 9:30 PM
- +1 ;;5.3;Scheduling;**177,505**;AUG 13, 1993;Build 20
- +2 ;
- PTDET NEW DIC,SC,DFN,SCPT0,X,Y,SCDT,DTOUT,DUOUT
- +1 DO TITL^SCRPW50("Historical Patient Assignment Detail")
- +2 SET DIC="^DPT("
- SET DIC(0)="AEMQZ"
- DO ^DIC
- IF $DATA(DTOUT)!$DATA(DUOUT)
- GOTO EXIT
- +3 if Y<1
- GOTO EXIT
- SET DFN=+Y
- SET SCPT0=Y(0)
- SET SC="SC"
- SET SCDT("B")="TODAY"
- +4 if '$$DTR^SCRPO(.SC,.SCDT,.SCDT)
- GOTO EXIT
- +5 NEW ZTSAVE
- FOR X="DFN","SCPT0","SC("
- SET ZTSAVE(X)=""
- +6 WRITE !
- DO EN^XUTMDEVQ("RUN^SCRPO5","Historical Patient Assignment Detail",.ZTSAVE)
- EXIT DO DISP0^SCRPW23
- DO END^SCRPW50
- QUIT
- +1 ;
- RUN ;Print report
- +1 NEW SCI,SCPNOW,SCLINE,SCPAGE,SCSUB,SCFF,SCFOUND,SCLN,SCAGE,SCDATA
- +2 NEW SCDOB,SCGEND,SCIFN,SCOUT,SCPNAME,SCREC,SCSH,SCSSN,SCTITL,SCDT
- +3 NEW SCEU,SCEUNM,SCLEBNM,SCLEDT,SCSTAT,SCSTNM,SCX,SCY
- +4 KILL ^TMP("SCRPT",$JOB)
- MERGE SCDT=SC("DTR")
- SET SCDT="SCDT"
- +5 SET SCI=$$GETALL^SCAPMCA(DFN,.SCDT)
- SET SCSUB=""
- SET (SCFF,SCLN,SCFOUND,SCOUT)=0
- +6 FOR
- SET SCSUB=$ORDER(^TMP("SC",$JOB,DFN,SCSUB))
- if SCSUB=""!(SCSUB]"PCTM")
- QUIT
- Begin DoDot:1
- +7 SET SCX=$PIECE($TEXT(@SCSUB),";;",2)
- FOR SCI=1:1:9
- SET SCX(SCI)=$PIECE(SCX,U,SCI)
- +8 SET ^TMP("SCRPT",$JOB,SCX(1))=SCX(2)
- SET SCX(3)=U_SCX(3)
- +9 SET SCI=0
- FOR
- SET SCI=$ORDER(^TMP("SC",$JOB,DFN,SCSUB,SCI))
- if 'SCI
- QUIT
- Begin DoDot:2
- +10 SET SCDATA=^TMP("SC",$JOB,DFN,SCSUB,SCI)
- +11 ;provider/position/team name
- SET SCNAME=$PIECE(SCDATA,U,SCX(8))
- +12 ;history record ifn
- SET SCIFN=$PIECE(SCDATA,U,SCX(4))
- +13 ;active date
- SET SCACT=$PIECE(SCDATA,U,SCX(5))
- +14 if 'SCACT
- QUIT
- +15 ;inactive date
- SET SCINAC=$PIECE(SCDATA,U,SCX(6))
- +16 ;history record
- SET SCREC=$GET(@SCX(3)@(SCIFN,0))
- +17 if '$LENGTH(SCREC)
- QUIT
- +18 ;user duz
- SET SCUSER=$PIECE(SCREC,U,SCX(7))
- +19 ;date entered
- SET SCDENT=$PIECE(SCREC,U,SCX(9))
- +20 ;editing user
- SET SCEU=$PIECE(SCREC,U,6)
- SET SCEUNM=$$GET1^DIQ(200,SCEU_",",.01)
- +21 ;status
- SET SCSTAT=$PIECE(SCREC,U,12)
- SET SCSTNM=$$GET1^DIQ(404.43,SCIFN_",",.12)
- +22 ;last edited by
- SET SCLEDT=$PIECE(SCREC,U,8)
- SET SCLEBNM=$$GET1^DIQ(200,SCLEDT_",",.01)
- +23 DO SLINE(SCX(1),SCNAME,SCACT,SCINAC,SCUSER,SCDENT,SCEUNM,SCSTNM,SCLEBNM,.SCLN)
- +24 QUIT
- End DoDot:2
- +25 QUIT
- End DoDot:1
- +26 SET SCTITL(1)="<*> HISTORICAL PATIENT ASSIGNMENT DETAIL <*>"
- +27 SET SCTITL(2)="For assignments effective "_SC("DTR","PBDT")_" to "_SC("DTR","PEDT")
- +28 SET SCLINE=""
- SET $PIECE(SCLINE,"-",81)=""
- SET SCPAGE=1
- +29 SET Y=$$NOW^XLFDT()
- XECUTE ^DD("DD")
- SET SCPNOW=$PIECE(Y,":",1,2)
- +30 SET SCPNAME=$PIECE(SCPT0,U)
- SET SCSSN=$PIECE(SCPT0,U,9)
- +31 SET SCGEND=$SELECT($PIECE(SCPT0,U,2)="M":"MALE",1:"FEMALE")
- +32 SET (Y,SCAGE)=$PIECE(SCPT0,U,3)
- XECUTE ^DD("DD")
- SET SCDOB=Y
- +33 SET SCAGE=$EXTRACT(DT,1,3)-$EXTRACT(SCAGE,1,3)-($EXTRACT(DT,4,7)<$EXTRACT(SCAGE,4,7))
- +34 if $EXTRACT(IOST)="C"
- DO DISP0^SCRPW23
- DO HDR^SCRPO(.SCTITL,80)
- DO SHDR
- +35 if 'SCFOUND
- WRITE !!?21,"No assignments found for this patient."
- +36 IF SCFOUND
- SET SCSUB=0
- FOR
- SET SCSUB=$ORDER(^TMP("SCRPT",$JOB,SCSUB))
- if 'SCSUB!SCOUT
- QUIT
- Begin DoDot:1
- +37 if $Y>(IOSL-5)
- DO HDR^SCRPO(.SCTITL,80)
- DO SHDR
- if SCOUT
- QUIT
- +38 SET SCSH=^TMP("SCRPT",$JOB,SCSUB)
- +39 if SCSUB>1
- WRITE !
- DO SSHDR(SCSH)
- SET SCACT=""
- +40 IF '$ORDER(^TMP("SCRPT",$JOB,SCSUB,""))
- WRITE " (none found)"
- QUIT
- +41 FOR
- SET SCACT=$ORDER(^TMP("SCRPT",$JOB,SCSUB,SCACT))
- if SCACT=""!SCOUT
- QUIT
- Begin DoDot:2
- +42 SET SCI=0
- FOR
- SET SCI=$ORDER(^TMP("SCRPT",$JOB,SCSUB,SCACT,SCI))
- if 'SCI!SCOUT
- QUIT
- Begin DoDot:3
- +43 if $Y>(IOSL-3)
- DO HDR^SCRPO(.SCTITL,80)
- DO SHDR
- DO SSHDR(SCSH,1)
- if SCOUT
- QUIT
- +44 SET SCX=^TMP("SCRPT",$JOB,SCSUB,SCACT,SCI)
- +45 WRITE !,$PIECE(SCX,U),?28,$PIECE(SCX,U,2),?40,$PIECE(SCX,U,3),?52,$PIECE(SCX,U,4)
- +46 IF SCSUB=3
- Begin DoDot:4
- +47 WRITE !,"User Entering: ",$PIECE(SCX,U,6)
- +48 WRITE !,"Last Edited By: ",$PIECE(SCX,U,7)
- +49 WRITE !,"Status: ",$PIECE(SCX,U,5)
- End DoDot:4
- +50 QUIT
- End DoDot:3
- +51 QUIT
- End DoDot:2
- +52 QUIT
- End DoDot:1
- +53 IF 'SCOUT
- IF $EXTRACT(IOST)="C"
- NEW DIR
- SET DIR(0)="E"
- WRITE !
- DO ^DIR
- +54 KILL ^TMP("SCRPT",$JOB)
- QUIT
- +55 ;
- SHDR ;Subheader
- +1 if SCOUT
- QUIT
- +2 WRITE !,"Patient: ",$EXTRACT(SCPNAME,1,18),?29,"SSN: ",SCSSN,?46,"DOB: ",SCDOB
- +3 WRITE ?64,"AGE: ",SCAGE,?74,$JUSTIFY(SCGEND,6),!,SCLINE
- +4 if 'SCFOUND
- QUIT
- +5 WRITE !,"Assignment",?28,"Active",?40,"Inactive",?52,"Assigned by/date"
- +6 WRITE !,"-------------------------- ---------- ---------- ----------------------------"
- +7 QUIT
- +8 ;
- SSHDR(X,CONT) ;Subheader
- +1 ;Input: X=category
- +2 ;Input: CONT='1' for continuation (optional)
- +3 WRITE !,X,$SELECT($GET(CONT):" (cont.)",1:""),":"
- +4 QUIT
- +5 ;
- SLINE(SCORD,SCNAME,SCACT,SCINAC,SCUSER,SCDENT,SUNM,SCTNM,SCBNM,SCLN) ;Set report global
- +1 ;Input: SCORD=output order
- +2 ;Input: SCNAME=provider/position/team name
- +3 ;Input: SCACT=active date
- +4 ;Input: SCINAC=inactive date
- +5 ;Input: SCUSER=user duz
- +6 ;Input: SCDENT=date entered
- +7 ;Input: SUNM=entered by
- +8 ;Input: SCTNM=status
- +9 ;Input: SCBNM=last edited by
- +10 ;
- +11 ;N SCX,SCY
- +12 SET SCFOUND=1
- SET SCLN=SCLN+1
- +13 SET SCX=$EXTRACT(SCNAME,1,25)_U_$$SDT(SCACT)_U_$$SDT(SCINAC)
- SET SCY=$$SDT(SCDENT)
- +14 if $LENGTH(SCY)
- SET SCY=" ("_SCY_")"
- +15 SET SCX=SCX_U_$EXTRACT($PIECE($GET(^VA(200,+SCUSER,0)),U),1,(28-$LENGTH(SCY)))_SCY_U_SCTNM_U_SUNM_U_SCBNM
- +16 SET ^TMP("SCRPT",$JOB,SCORD,-SCACT,SCLN)=SCX
- +17 QUIT
- +18 ;
- CODE ;Data handling instructions
- +1 ; The following $TEXT lines contain data handling instructions
- +2 ; in the format: $PIECE 1 = output order
- +3 ; 2 = subtitle
- +4 ; 3 = global reference of history record
- +5 ; 4 = $piece of history record ifn
- +6 ; 5 = $piece of active date
- +7 ; 6 = $piece of inactive date
- +8 ; 7 = $piece of user (in history record)
- +9 ; 8 = $piece of provider/position/team name
- +10 ; 9 = $piece of date entered
- +11 ;
- NPCPOS ;;7^Non-PC Position^SCPT(404.43)^4^5^6^6^2^7
- NPCPPOS ;;9^Non-PC Preceptor Position^SCTM(404.53)^16^14^15^7^2^8
- NPCPPR ;;8^Non-PC Preceptor Provider^SCTM(404.52)^11^9^10^7^2^8
- NPCPR ;;6^Non-PC Provider^SCTM(404.52)^11^9^10^7^2^8
- NPCTM ;;10^Non-PC Team^SCPT(404.42)^3^4^5^11^2^12
- PCAP ;;2^PC Associate Provider^SCTM(404.52)^11^9^10^7^2^8
- PCPOS ;;3^PC Position^SCPT(404.43)^4^5^6^6^2^7
- PCPPOS ;;4^PC Preceptor Position^SCTM(404.53)^16^14^15^7^2^8
- PCPR ;;1^PC Provider^SCTM(404.52)^11^9^10^7^2^8
- PCTM ;;5^PC Team^SCPT(404.42)^3^4^5^11^2^12
- +1 ;
- SDT(X) ;Slashed date
- +1 SET X=$EXTRACT(X,1,7)
- if X'?7N
- QUIT ""
- +2 QUIT $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(17+$EXTRACT(X))_$EXTRACT(X,2,3)
